forked from Imagelibrary/binutils-gdb
76bdc7266a
This adds 'Innovative Computing Labs' as an external author to update-copyright.py, to cover the copyright notice in gprofng/common/opteron_pcbe.c, and uses that plus another external author 'Oracle and' to update gprofng copyright dates. I'm not going to commit 'Oracle and' as an accepted author, but that covers the string "Copyright (c) 2006, 2012, Oracle and/or its affiliates. All rights reserved." found in gprofng/testsuite/gprofng.display/jsynprog files.
14920 lines
578 KiB
Perl
14920 lines
578 KiB
Perl
#!/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;
|
|
use feature qw (state);
|
|
use File::stat;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check as early as possible if the version of Perl used is supported.
|
|
#------------------------------------------------------------------------------
|
|
INIT
|
|
{
|
|
my $perl_minimal_version_supported = version->parse ("5.10.0")->normal;
|
|
my $perl_current_version = version->parse ("$]")->normal;
|
|
|
|
if ($perl_current_version lt $perl_minimal_version_supported)
|
|
{
|
|
my $msg;
|
|
|
|
$msg = "Error: minimum Perl release required: ";
|
|
$msg .= $perl_minimal_version_supported;
|
|
$msg .= " current: ";
|
|
$msg .= $perl_current_version;
|
|
$msg .= "\n";
|
|
|
|
print $msg;
|
|
|
|
exit (1);
|
|
}
|
|
} #-- End of INIT
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Poor man's version of a boolean.
|
|
#------------------------------------------------------------------------------
|
|
my $TRUE = 1;
|
|
my $FALSE = 0;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Used to ensure correct alignment of columns.
|
|
#------------------------------------------------------------------------------
|
|
my $g_max_length_first_metric;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This variable contains the path used to execute $GP_DISPAY_TEXT.
|
|
#------------------------------------------------------------------------------
|
|
my $g_path_to_tools;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Code debugging flag
|
|
#-------------------------------------------------------------------------------
|
|
my $g_test_code = $FALSE;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# GPROFNG commands and files used.
|
|
#-------------------------------------------------------------------------------
|
|
my $GP_DISPLAY_TEXT = "gp-display-text";
|
|
|
|
my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log";
|
|
my $g_gp_error_logfile = $GP_DISPLAY_TEXT.".stderr.log";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Global variables.
|
|
#------------------------------------------------------------------------------
|
|
my $g_addressing_mode = "64 bit";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The global regex section.
|
|
#
|
|
# First step towards consolidating all regexes.
|
|
#------------------------------------------------------------------------------
|
|
my $g_less_than_regex = '<';
|
|
my $g_html_less_than_regex = '<';
|
|
my $g_endbr_inst_regex = 'endbr[32|64]';
|
|
|
|
#------------------------------------------------------------------------------
|
|
# These are the regex's used.
|
|
#------------------------------------------------------------------------------
|
|
#------------------------------------------------------------------------------
|
|
# Disassembly analysis
|
|
#------------------------------------------------------------------------------
|
|
my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)';
|
|
my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])';
|
|
my $g_function_call_v2_regex = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*';
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Convenience. These map the on/off value to $TRUE/$FALSE to make the code
|
|
# easier to read. For example: "if ($g_verbose)" as opposed to the following:
|
|
# "if ($verbose_setting eq "on").
|
|
#------------------------------------------------------------------------------
|
|
my $g_verbose;
|
|
my $g_warnings;
|
|
my $g_quiet;
|
|
|
|
my $g_first_metric;
|
|
|
|
my $binutils_version;
|
|
my $driver_cmd;
|
|
my $tool_name;
|
|
my $version_info;
|
|
|
|
my %g_mapped_cmds = ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD All warning messages are collected and are accessible through the main
|
|
# page.
|
|
#------------------------------------------------------------------------------
|
|
my @g_warning_messages = ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Contains the names that have already been tagged. This is a global
|
|
# structure because otherwise the code would get much more complicated.
|
|
#------------------------------------------------------------------------------
|
|
my %g_tagged_names = ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD Remove the use of these structures. No longer used.
|
|
#------------------------------------------------------------------------------
|
|
my %g_function_tag_id = ();
|
|
my $g_context = 5; # Defines the range of scan
|
|
|
|
my $g_default_setting_lang = "en-US.UTF-8";
|
|
my %g_exp_dir_meta_data;
|
|
|
|
my @g_user_input_errors = ();
|
|
|
|
my $g_html_credits_line;
|
|
|
|
my $g_warn_keyword = "Input warning: ";
|
|
my $g_error_keyword = "Input error: ";
|
|
|
|
my %g_function_occurrences = ();
|
|
my %g_map_function_to_index = ();
|
|
my %g_multi_count_function = ();
|
|
my %g_function_view_all = ();
|
|
my @g_full_function_view_table = ();
|
|
|
|
my @g_html_experiment_stats = ();
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# These structures contain the information printed in the function views.
|
|
#-------------------------------------------------------------------------------
|
|
my $g_header_lines;
|
|
|
|
my @g_html_function_name = ();
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# TBD: This variable may not be needed and replaced by tp_value
|
|
my $thresh = 0;
|
|
#-------------------------------------------------------------------------------
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Define the driver command, tool name and version number.
|
|
#-------------------------------------------------------------------------------
|
|
$driver_cmd = "gprofng display html";
|
|
$tool_name = "gp-display-html";
|
|
#$binutils_version = "2.38.50";
|
|
$binutils_version = "BINUTILS_VERSION";
|
|
$version_info = $tool_name . " GNU binutils version " . $binutils_version;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Define several key data structures.
|
|
#-------------------------------------------------------------------------------
|
|
my %g_user_settings =
|
|
(
|
|
output => { option => "-o" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE},
|
|
overwrite => { option => "-O" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE},
|
|
calltree => { option => "-ct", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
|
|
func_limit => { option => "-fl", no_of_arguments => 1, data_type => "pinteger", current_value => 500 , defined => $FALSE},
|
|
highlight_percentage => { option => "-hp", no_of_arguments => 1, data_type => "pfloat" , current_value => 90.0 , defined => $FALSE},
|
|
threshold_percentage => { option => "-tp", no_of_arguments => 1, data_type => "pfloat" , current_value => 100.0 , defined => $FALSE},
|
|
default_metrics => { option => "-dm", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
|
|
ignore_metrics => { option => "-im", no_of_arguments => 1, data_type => "metric_names", current_value => undef, defined => $FALSE},
|
|
verbose => { option => "--verbose" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
|
|
warnings => { option => "--warnings" , no_of_arguments => 1, data_type => "onoff" , current_value => "on" , defined => $FALSE},
|
|
debug => { option => "--debug" , no_of_arguments => 1, data_type => "size" , current_value => "off" , defined => $FALSE},
|
|
quiet => { option => "--quiet" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE},
|
|
);
|
|
|
|
my %g_debug_size =
|
|
(
|
|
"on" => $FALSE,
|
|
"s" => $FALSE,
|
|
"m" => $FALSE,
|
|
"l" => $FALSE,
|
|
"xl" => $FALSE,
|
|
);
|
|
|
|
my %local_system_config =
|
|
(
|
|
kernel_name => "undefined",
|
|
nodename => "undefined",
|
|
kernel_release => "undefined",
|
|
kernel_version => "undefined",
|
|
machine => "undefined",
|
|
processor => "undefined",
|
|
hardware_platform => "undefined",
|
|
operating_system => "undefined",
|
|
hostname_current => "undefined",
|
|
);
|
|
|
|
# Note that we use single quotes here, because regular expressions wreak havoc otherwise.
|
|
|
|
my %g_arch_specific_settings =
|
|
(
|
|
arch_supported => $FALSE,
|
|
arch => 'undefined',
|
|
regex => 'undefined',
|
|
subexp => 'undefined',
|
|
linksubexp => 'undefined',
|
|
);
|
|
|
|
my %g_locale_settings = (
|
|
LANG => "en_US.UTF-8",
|
|
decimal_separator => "\\.",
|
|
covert_to_dot => $FALSE
|
|
);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# See this page for a nice overview with the colors:
|
|
# https://www.w3schools.com/colors/colors_groups.asp
|
|
#------------------------------------------------------------------------------
|
|
|
|
my %g_html_color_scheme = (
|
|
"control_flow" => "Brown",
|
|
"target_function_name" => "Red",
|
|
"non_target_function_name" => "BlueViolet",
|
|
"background_color_hot" => "PeachPuff",
|
|
"background_color_lukewarm" => "LemonChiffon",
|
|
"link_outside_range" => "Crimson",
|
|
"error_message" => "LightPink",
|
|
"background_color_page" => "White",
|
|
# "background_color_page" => "LightGray",
|
|
"background_selected_sort" => "LightSlateGray",
|
|
"index" => "Lavender",
|
|
);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# These are the base names for the HTML files that are generated.
|
|
#------------------------------------------------------------------------------
|
|
my %g_html_base_file_name = (
|
|
"caller_callee" => "caller-callee",
|
|
"disassembly" => "dis",
|
|
"experiment_info" => "experiment-info",
|
|
"function_view" => "function-view-sorted",
|
|
"index" => "index",
|
|
"source" => "src",
|
|
"warnings" => "warnings",
|
|
);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is cosmetic, but helps with the scoping of variables.
|
|
#------------------------------------------------------------------------------
|
|
main ();
|
|
|
|
exit (0);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is the driver part of the program.
|
|
#------------------------------------------------------------------------------
|
|
sub main
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The name of the configuration file.
|
|
#------------------------------------------------------------------------------
|
|
my $rc_file_name = ".gp-display-html.rc";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# OS commands executed and search paths.
|
|
#------------------------------------------------------------------------------
|
|
my @selected_os_cmds = qw (rm mv cat hostname locale which printenv ls
|
|
uname readelf mkdir);
|
|
my @search_paths_os_cmds = qw (
|
|
/usr/bin
|
|
/bin
|
|
/usr/local/bin
|
|
/usr/local/sbin
|
|
/usr/sbin
|
|
/sbin
|
|
);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Eliminate these.
|
|
#------------------------------------------------------------------------------
|
|
my $ARCHIVES_MAP_NAME;
|
|
my $ARCHIVES_MAP_VADDR;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Local structures (hashes and arrays).
|
|
#------------------------------------------------------------------------------
|
|
my @exp_dir_list; # List with experiment directories
|
|
my @metrics_data;
|
|
|
|
my %function_address_info = ();
|
|
my $function_address_info_ref;
|
|
|
|
my @function_info = ();
|
|
my $function_info_ref;
|
|
|
|
my %function_address_and_index = ();
|
|
my $function_address_and_index_ref;
|
|
|
|
my %addressobjtextm = ();
|
|
my $addressobjtextm_ref;
|
|
|
|
my %addressobj_index = ();
|
|
my $addressobj_index_ref;
|
|
|
|
my %LINUX_vDSO = ();
|
|
my $LINUX_vDSO_ref;
|
|
|
|
my %function_view_structure = ();
|
|
my $function_view_structure_ref;
|
|
|
|
my %elf_rats = ();
|
|
my $elf_rats_ref;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Local variables.
|
|
#------------------------------------------------------------------------------
|
|
my $abs_path_outputdir;
|
|
my $archive_dir_not_empty;
|
|
my $base_va_executable;
|
|
my $executable_name;
|
|
my $exp_dir_list_ref;
|
|
my $found_exp_dir;
|
|
my $ignore_value;
|
|
my $message;
|
|
my $number_of_metrics;
|
|
my $va_executable_in_hex;
|
|
|
|
my $failed_command_mappings;
|
|
my $option_errors;
|
|
my $total_user_errors;
|
|
|
|
my $script_pc_metrics;
|
|
my $dir_check_errors;
|
|
my $consistency_errors;
|
|
my $outputdir;
|
|
my $return_code;
|
|
|
|
my $decimal_separator;
|
|
my $convert_to_dot;
|
|
my $architecture_supported;
|
|
my $elf_arch;
|
|
my $elf_support;
|
|
my $home_dir;
|
|
my $elf_loadobjects_found;
|
|
|
|
my $rc_file_paths_ref;
|
|
my @rc_file_paths = ();
|
|
my $rc_file_errors = 0;
|
|
|
|
my @sort_fields = ();
|
|
my $summary_metrics;
|
|
my $call_metrics;
|
|
my $user_metrics;
|
|
my $system_metrics;
|
|
my $wall_metrics;
|
|
my $detail_metrics;
|
|
my $detail_metrics_system;
|
|
|
|
my $pretty_dir_list;
|
|
|
|
my %metric_value = ();
|
|
my %metric_description = ();
|
|
my %metric_description_reversed = ();
|
|
my %metric_found = ();
|
|
my %ignored_metrics = ();
|
|
|
|
my $metric_value_ref;
|
|
my $metric_description_ref;
|
|
my $metric_found_ref;
|
|
my $ignored_metrics_ref;
|
|
|
|
my @table_execution_stats = ();
|
|
my $table_execution_stats_ref;
|
|
|
|
my $html_first_metric_file_ref;
|
|
my $html_first_metric_file;
|
|
|
|
my $arch;
|
|
my $subexp;
|
|
my $linksubexp;
|
|
|
|
my $setting_for_LANG;
|
|
my $time_percentage_multiplier;
|
|
my $process_all_functions;
|
|
|
|
my $selected_archive;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If no options are given, print the help info and exit.
|
|
#------------------------------------------------------------------------------
|
|
if ($#ARGV == -1)
|
|
{
|
|
$ignore_value = print_help_info ();
|
|
return (0);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This part is like a preamble. Before we continue we need to figure out some
|
|
# things that are needed later on.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Store the absolute path of the command executed.
|
|
#------------------------------------------------------------------------------
|
|
my $location_gp_command = $0;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The very first thing to do is to quickly determine if the user has enabled
|
|
# one of the following options and take action accordingly:
|
|
# --version, --verbose, --debug, --quiet
|
|
#
|
|
# This avoids that there is a gap between the start of the execution and the
|
|
# moment the options are parsed, checked, and interpreted.
|
|
#
|
|
# When parsing the full command line, these options will be more extensively
|
|
# checked and also updated in %g_user_settings
|
|
|
|
# Note that a confirmation message, if any, is printed here and not when the
|
|
# options are parsed and processed.
|
|
#------------------------------------------------------------------------------
|
|
|
|
$g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE;
|
|
$g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE;
|
|
$g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE;
|
|
|
|
$ignore_value = early_scan_specific_options ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The next subroutine is executed early to ensure the OS commands we need are
|
|
# available.
|
|
#
|
|
# This subroutine stores the commands and the full path names as an associative
|
|
# array called "g_mapped_cmds". The command is the key and the value is the full
|
|
# path. For example: ("uname", /usr/bin/uname).
|
|
#------------------------------------------------------------------------------
|
|
$failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, \@search_paths_os_cmds);
|
|
|
|
if ($failed_command_mappings == 0)
|
|
{
|
|
gp_message ("debug", $subr_name, "verified the OS commands");
|
|
}
|
|
else
|
|
{
|
|
my $msg = "failure in the verification of the OS commands";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the home directory and the locations for the configuration file on the
|
|
# current system.
|
|
#------------------------------------------------------------------------------
|
|
($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name);
|
|
|
|
@rc_file_paths = @{ $rc_file_paths_ref };
|
|
gp_message ("debug", $subr_name, "the home directory is $home_dir");
|
|
gp_message ("debugXL", $subr_name, "the search path for the rc file is @rc_file_paths");
|
|
|
|
$pretty_dir_list = build_pretty_dir_list (\@rc_file_paths);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the ball rolling. Parse and interpret the configuration file (if any)
|
|
# and the command line options.
|
|
#
|
|
# If either $rc_file_errors or $total_user_errors, or both, are non-zero it
|
|
# means a fatal error has occured. In this case, all error messages are
|
|
# printed and execution is terminated.
|
|
#
|
|
# Note that the verbose, debug, and quiet options can be set in this file.
|
|
# It is a deliberate choice to ignore these for now. The assumption is that
|
|
# the user will not be happy if we ignore the command line settings for a
|
|
# while.
|
|
#------------------------------------------------------------------------------
|
|
|
|
gp_message ("debugXL", $subr_name, "processing of the rc file disabled for now");
|
|
|
|
# Temporarily disabled print_table_user_settings ("debugXL", "before function process_rc_file");
|
|
# Temporarily disabled
|
|
# Temporarily disabled $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref);
|
|
# Temporarily disabled
|
|
# Temporarily disabled if ($rc_file_errors != 0)
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $message = "fatal errors in file $rc_file_name encountered";
|
|
# Temporarily disabled gp_message ("debugXL", $subr_name, $message);
|
|
# Temporarily disabled }
|
|
# Temporarily disabled
|
|
# Temporarily disabled print_table_user_settings ("debugXL", "after function process_rc_file");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the ball rolling. Parse and interpret the options. Some first checks
|
|
# are performed.
|
|
#
|
|
# Instead of bailing out on the first user error, we capture all errors, print
|
|
# messages and then bail out. This is more user friendly.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Parse the user options");
|
|
|
|
$total_user_errors = 0;
|
|
|
|
($option_errors, $found_exp_dir, $exp_dir_list_ref) = parse_and_check_user_options (
|
|
\$#ARGV,
|
|
\@ARGV);
|
|
$total_user_errors += $option_errors;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Dynamically load the modules needed. If a module is not available, print
|
|
# an error message and bail out.
|
|
#
|
|
# This call replaces the following:
|
|
#
|
|
# use feature qw (state);
|
|
# use List::Util qw (min max);
|
|
# use Cwd;
|
|
# use File::Basename;
|
|
# use File::stat;
|
|
# use POSIX;
|
|
# use bignum;
|
|
#
|
|
# Note that this check cannot be done earlier, because in case of a missing
|
|
# module, the man page would not be generated if the code ends prematurely
|
|
# in case the --help and --version options are used..
|
|
#------------------------------------------------------------------------------
|
|
my ($module_errors_ref, $missing_modules_ref) = handle_module_availability ();
|
|
|
|
my $module_errors = ${ $module_errors_ref };
|
|
|
|
if ($module_errors > 0)
|
|
{
|
|
my $msg;
|
|
|
|
my $plural_or_single = ($module_errors > 1) ? "modules are" : "module is";
|
|
my @missing_modules = @{ $missing_modules_ref };
|
|
|
|
for my $i (0 .. $#missing_modules)
|
|
{
|
|
$msg = "module $missing_modules[$i] is missing";
|
|
gp_message ("error", $subr_name, $msg);
|
|
}
|
|
|
|
$msg = $module_errors . " " . $plural_or_single .
|
|
"missing - execution is terminated";
|
|
gp_message ("abort", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The user options have been taken in. Check for validity and consistency.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Process user options");
|
|
|
|
($option_errors, $ignored_metrics_ref, $outputdir,
|
|
$time_percentage_multiplier, $process_all_functions,
|
|
$exp_dir_list_ref) = process_user_options ($exp_dir_list_ref);
|
|
|
|
@exp_dir_list = @{ $exp_dir_list_ref };
|
|
%ignored_metrics = %{$ignored_metrics_ref};
|
|
|
|
$total_user_errors += $option_errors;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If no option is given for the output directory, pick a default. Otherwise,
|
|
# if the output directory exists, wipe it clean in case the -O option is used.
|
|
# If not, flag an error because the -o option does not overwrite an existing
|
|
# directory.
|
|
#------------------------------------------------------------------------------
|
|
if ($total_user_errors == 0)
|
|
{
|
|
($option_errors, $outputdir) = set_up_output_directory ();
|
|
$abs_path_outputdir = cwd () . "/" . $outputdir;
|
|
$total_user_errors += $option_errors;
|
|
}
|
|
|
|
if ($total_user_errors == 0)
|
|
{
|
|
gp_message ("debug", $subr_name, "the output directory is $outputdir");
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# All command line errors and warnings are printed here.
|
|
#------------------------------------------------------------------------------
|
|
my $plural_or_single = ($total_user_errors > 1) ? "errors have" : "error has";
|
|
$message = $g_error_keyword;
|
|
$message .= $total_user_errors;
|
|
if ($rc_file_errors > 0)
|
|
{
|
|
$message .= " additional";
|
|
}
|
|
$message .= " fatal input $plural_or_single been detected:";
|
|
gp_message ("error", $subr_name, $message);
|
|
for my $key (keys @g_user_input_errors)
|
|
{
|
|
gp_message ("error", $subr_name, "$g_error_keyword $g_user_input_errors[$key]");
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Bail out in case fatal errors have occurred.
|
|
#------------------------------------------------------------------------------
|
|
if ( ($rc_file_errors + $total_user_errors) > 0)
|
|
{
|
|
my $msg = "the current values for the user controllable settings";
|
|
print_user_settings ("debug", $msg);
|
|
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
else
|
|
{
|
|
my $msg = "after parsing the user options, the final values are";
|
|
print_user_settings ("debug", $msg);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Enable once all planned features have been implemented and tested.
|
|
#------------------------------------------------------------------------------
|
|
# Temporarily disabled $msg = "the final values for the user controllable settings";
|
|
# Temporarily disabled print_table_user_settings ("verbose", $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print a list with the experiment directory names
|
|
#------------------------------------------------------------------------------
|
|
$pretty_dir_list = build_pretty_dir_list (\@exp_dir_list);
|
|
|
|
my $plural = ($#exp_dir_list > 0) ? "directories are" : "directory is";
|
|
|
|
gp_message ("verbose", $subr_name, "The experiment " . $plural . ":");
|
|
gp_message ("verbose", $subr_name, $pretty_dir_list);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Set up the first entry with the meta data for the experiments. This field
|
|
# contains the absolute paths to the experiment directories.
|
|
#------------------------------------------------------------------------------
|
|
for my $exp_dir (@exp_dir_list)
|
|
{
|
|
my ($filename, $directory_path, $ignore_suffix) = fileparse ($exp_dir);
|
|
gp_message ("debug", $subr_name, "exp_dir = $exp_dir");
|
|
gp_message ("debug", $subr_name, "filename = $filename");
|
|
gp_message ("debug", $subr_name, "directory_path = $directory_path");
|
|
$g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check whether the experiment directories are valid. If not, it is a fatal
|
|
# error.
|
|
# Upon successful return, one directory has been selected to be used in the
|
|
# remainder. This is not always the correct thing to do, but is the same as
|
|
# the original code. In due time this should be addressed though.
|
|
#------------------------------------------------------------------------------
|
|
($dir_check_errors, $archive_dir_not_empty, $selected_archive,
|
|
$elf_rats_ref) = check_validity_exp_dirs ($exp_dir_list_ref);
|
|
|
|
if ($dir_check_errors)
|
|
{
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("verbose", $subr_name, "The experiment directories have been verified and are valid");
|
|
}
|
|
|
|
%elf_rats = %{$elf_rats_ref};
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Now that we know the map.xml file(s) are present, we can scan these and get
|
|
# the required information. This includes setting the base virtual address.
|
|
#-------------------------------------------------------------------------------
|
|
$ignore_value = determine_base_virtual_address ($exp_dir_list_ref);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check whether the experiment directories are consistent.
|
|
#------------------------------------------------------------------------------
|
|
($consistency_errors, $executable_name) = verify_consistency_experiments ($exp_dir_list_ref);
|
|
|
|
if ($consistency_errors == 0)
|
|
{
|
|
gp_message ("verbose", $subr_name, "The experiment directories are consistent");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("abort", $subr_name, "number of consistency errors detected: $consistency_errors");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The directories are consistent. We can now set the base virtual address of
|
|
# the executable.
|
|
#------------------------------------------------------------------------------
|
|
$base_va_executable = $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"};
|
|
|
|
gp_message ("debug", $subr_name, "executable_name = $executable_name");
|
|
gp_message ("debug", $subr_name, "selected_archive = $selected_archive");
|
|
gp_message ("debug", $subr_name, "base_va_executable = $base_va_executable");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The $GP_DISPLAY_TEXT tool is critical and has to be available in order
|
|
# to proceed.
|
|
# This subroutine only returns a value if the tool can be found."
|
|
#------------------------------------------------------------------------------
|
|
$g_path_to_tools = ${ check_availability_tool (\$location_gp_command)};
|
|
|
|
$GP_DISPLAY_TEXT = $g_path_to_tools . $GP_DISPLAY_TEXT;
|
|
|
|
gp_message ("debug", $subr_name, "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if $GP_DISPLAY_TEXT is executable for user, group, and other.
|
|
# If not, print a warning only, since this may not be fatal but could
|
|
# potentially lead to issues later on.
|
|
#------------------------------------------------------------------------------
|
|
if (not is_file_executable ($GP_DISPLAY_TEXT))
|
|
{
|
|
my $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and other";
|
|
gp_message ("warning", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Find out what the decimal separator is, as set by the user.
|
|
#------------------------------------------------------------------------------
|
|
($return_code, $decimal_separator, $convert_to_dot) =
|
|
determine_decimal_separator ();
|
|
|
|
if ($return_code == 0)
|
|
{
|
|
my $txt = "decimal separator is $decimal_separator " .
|
|
"(conversion to dot is " .
|
|
($convert_to_dot == $TRUE ? "enabled" : "disabled").")";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
}
|
|
else
|
|
{
|
|
my $msg = "the decimal separator cannot be determined - set to $decimal_separator";
|
|
gp_message ("warning", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Collect and store the system information.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Collect system information and adapt settings");
|
|
|
|
$return_code = get_system_config_info ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The 3 variables below are used in the remainder.
|
|
#
|
|
# The output from "uname -p" is recommended to be used for the ISA.
|
|
#------------------------------------------------------------------------------
|
|
my $hostname_current = $local_system_config{hostname_current};
|
|
my $arch_uname_s = $local_system_config{kernel_name};
|
|
my $arch_uname = $local_system_config{processor};
|
|
|
|
gp_message ("debug", $subr_name, "set hostname_current = $hostname_current");
|
|
gp_message ("debug", $subr_name, "set arch_uname_s = $arch_uname_s");
|
|
gp_message ("debug", $subr_name, "set arch_uname = $arch_uname");
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# This function also sets the values in "g_arch_specific_settings". This
|
|
# includes several definitions of regular expressions.
|
|
#-------------------------------------------------------------------------------
|
|
($architecture_supported, $elf_arch, $elf_support) =
|
|
set_system_specific_variables ($arch_uname, $arch_uname_s);
|
|
|
|
gp_message ("debug", $subr_name, "architecture_supported = $architecture_supported");
|
|
gp_message ("debug", $subr_name, "elf_arch = $elf_arch");
|
|
gp_message ("debug", $subr_name, "elf_support = ".($elf_arch ? "TRUE" : "FALSE"));
|
|
|
|
for my $feature (sort keys %g_arch_specific_settings)
|
|
{
|
|
gp_message ("debug", $subr_name, "g_arch_specific_settings{$feature} = $g_arch_specific_settings{$feature}");
|
|
}
|
|
|
|
$arch = $g_arch_specific_settings{"arch"};
|
|
$subexp = $g_arch_specific_settings{"subexp"};
|
|
$linksubexp = $g_arch_specific_settings{"linksubexp"};
|
|
|
|
$g_locale_settings{"LANG"} = get_LANG_setting ();
|
|
|
|
gp_message ("debugXL", $subr_name, "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Temporarily reset selected settings since these are not yet implemented.
|
|
#------------------------------------------------------------------------------
|
|
$ignore_value = reset_selected_settings ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Revisit. Is this really necessary?
|
|
#------------------------------------------------------------------------------
|
|
|
|
($executable_name, $va_executable_in_hex) = check_loadobjects_are_elf ($selected_archive);
|
|
$elf_loadobjects_found = $TRUE;
|
|
|
|
# TBD: Hack and those ARCHIVES_ names can be eliminated
|
|
$ARCHIVES_MAP_NAME = $executable_name;
|
|
$ARCHIVES_MAP_VADDR = $va_executable_in_hex;
|
|
gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
|
|
gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
|
|
|
|
gp_message ("debugXL", $subr_name, "after call to check_loadobjects_are_elf forced elf_loadobjects_found = $elf_loadobjects_found");
|
|
|
|
$g_html_credits_line = ${ create_html_credits () };
|
|
gp_message ("debugXL", $subr_name, "g_html_credits_line = $g_html_credits_line");
|
|
#------------------------------------------------------------------------------
|
|
# Add a "/" to simplify the construction of path names in the remainder.
|
|
#
|
|
# TBD: Push this into a subroutine(s).
|
|
#------------------------------------------------------------------------------
|
|
$outputdir = append_forward_slash ($outputdir);
|
|
|
|
gp_message ("debug", $subr_name, "prepared outputdir = $outputdir");
|
|
|
|
#------------------------------------------------------------------------------
|
|
#------------------------------------------------------------------------------
|
|
# ******* TBD: e.system not available on Linux!!
|
|
#------------------------------------------------------------------------------
|
|
#------------------------------------------------------------------------------
|
|
|
|
## my $summary_metrics = 'e.totalcpu';
|
|
$detail_metrics = 'e.totalcpu';
|
|
$detail_metrics_system = 'e.totalcpu:e.system';
|
|
$call_metrics = 'a.totalcpu';
|
|
|
|
my $cmd_options;
|
|
my $metrics_cmd;
|
|
|
|
my $outfile1 = $outputdir ."metrics";
|
|
my $outfile2 = $outputdir . "metrictotals";
|
|
my $gp_error_file = $outputdir . $g_gp_error_logfile;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is
|
|
# to get all the output in files $outfile1 and $outfile2. These are then
|
|
# parsed.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Gather the metrics data from the experiments");
|
|
|
|
$return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1, $outfile2, $gp_error_file);
|
|
|
|
if ($return_code != 0)
|
|
{
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Test this code
|
|
#------------------------------------------------------------------------------
|
|
open (METRICS, "<", $outfile1)
|
|
or die ("$subr_name - unable to open metric value data file $outfile1 for reading: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile1 for reading");
|
|
|
|
chomp (@metrics_data = <METRICS>);
|
|
close (METRICS);
|
|
|
|
for my $i (keys @metrics_data)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "metrics_data[$i] = $metrics_data[$i]");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process the generated metrics data.
|
|
#------------------------------------------------------------------------------
|
|
if ($g_user_settings{"default_metrics"}{"current_value"} eq "off")
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The metrics will be derived from the experiments.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("verbose", $subr_name, "Process the metrics data");
|
|
|
|
($metric_value_ref, $metric_description_ref, $metric_found_ref,
|
|
$user_metrics, $system_metrics, $wall_metrics,
|
|
$summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics
|
|
) = process_metrics_data ($outfile1, $outfile2, \%ignored_metrics);
|
|
|
|
%metric_value = %{ $metric_value_ref };
|
|
%metric_description = %{ $metric_description_ref };
|
|
%metric_found = %{ $metric_found_ref };
|
|
%metric_description_reversed = reverse %metric_description;
|
|
|
|
gp_message ("debugXL", $subr_name, "after the call to process_metrics_data");
|
|
for my $metric (sort keys %metric_value)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "metric_value{$metric} = $metric_value{$metric}");
|
|
}
|
|
for my $metric (sort keys %metric_description)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "metric_description{$metric} = $metric_description{$metric}");
|
|
}
|
|
gp_message ("debugXL", $subr_name, "user_metrics = $user_metrics");
|
|
gp_message ("debugXL", $subr_name, "system_metrics = $system_metrics");
|
|
gp_message ("debugXL", $subr_name, "wall_metrics = $wall_metrics");
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# A default set of metrics will be used.
|
|
#
|
|
# TBD: These should be OS dependent.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Select the set of default metrics");
|
|
|
|
($metric_description_ref, $metric_found_ref, $summary_metrics,
|
|
$detail_metrics, $detail_metrics_system, $call_metrics
|
|
) = set_default_metrics ($outfile1, \%ignored_metrics);
|
|
|
|
|
|
%metric_description = %{ $metric_description_ref };
|
|
%metric_found = %{ $metric_found_ref };
|
|
%metric_description_reversed = reverse %metric_description;
|
|
|
|
gp_message ("debug", $subr_name, "after the call to set_default_metrics");
|
|
|
|
}
|
|
|
|
$number_of_metrics = split (":", $summary_metrics);
|
|
|
|
gp_message ("debugXL", $subr_name, "summary_metrics = $summary_metrics");
|
|
gp_message ("debugXL", $subr_name, "detail_metrics = $detail_metrics");
|
|
gp_message ("debugXL", $subr_name, "detail_metrics_system = $detail_metrics_system");
|
|
gp_message ("debugXL", $subr_name, "call_metrics = $call_metrics");
|
|
gp_message ("debugXL", $subr_name, "number_of_metrics = $number_of_metrics");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD Find a way to better handle this situation:
|
|
#------------------------------------------------------------------------------
|
|
for my $im (keys %metric_found)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "metric_found{$im} = $metric_found{$im}");
|
|
}
|
|
for my $im (keys %ignored_metrics)
|
|
{
|
|
if (not exists ($metric_found{$im}))
|
|
{
|
|
gp_message ("debugXL", $subr_name, "user requested ignored metric (-im) $im does not exist in collected metrics");
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the information on the experiments.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Generate the experiment information");
|
|
|
|
my $exp_info_file_ref;
|
|
my $exp_info_file;
|
|
my $exp_info_ref;
|
|
my @exp_info;
|
|
|
|
my $experiment_data_ref;
|
|
|
|
$experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list);
|
|
my @experiment_data = @{ $experiment_data_ref };
|
|
|
|
for my $i (sort keys @experiment_data)
|
|
{
|
|
my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " .
|
|
$experiment_data[$i]{"exp_name_full"};
|
|
gp_message ("debugM", $subr_name, $msg);
|
|
}
|
|
|
|
$experiment_data_ref = process_experiment_info ($experiment_data_ref);
|
|
@experiment_data = @{ $experiment_data_ref };
|
|
|
|
for my $i (sort keys @experiment_data)
|
|
{
|
|
for my $fields (sort keys %{ $experiment_data[$i] })
|
|
{
|
|
my $msg = "i = $i experiment_data[$i]{$fields} = " .
|
|
$experiment_data[$i]{$fields};
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
@g_html_experiment_stats = @{ create_exp_info (
|
|
\@exp_dir_list,
|
|
\@experiment_data) };
|
|
|
|
$table_execution_stats_ref = html_generate_exp_summary (
|
|
\$outputdir,
|
|
\@experiment_data);
|
|
@table_execution_stats = @{ $table_execution_stats_ref };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the function overview.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Generate the list with functions executed");
|
|
|
|
my ($outfile, $sort_fields_ref) = get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir);
|
|
|
|
@sort_fields = @{$sort_fields_ref};
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse the output from the fsummary command and store the relevant data for
|
|
# all the functions listed there.
|
|
#------------------------------------------------------------------------------
|
|
|
|
gp_message ("verbose", $subr_name, "Analyze and store the relevant function information");
|
|
|
|
($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref,
|
|
$LINUX_vDSO_ref, $function_view_structure_ref) = get_function_info ($outfile);
|
|
|
|
@function_info = @{ $function_info_ref };
|
|
%function_address_and_index = %{ $function_address_and_index_ref };
|
|
%addressobjtextm = %{ $addressobjtextm_ref };
|
|
%LINUX_vDSO = %{ $LINUX_vDSO_ref };
|
|
%function_view_structure = %{ $function_view_structure_ref };
|
|
|
|
for my $keys (0 .. $#function_info)
|
|
{
|
|
for my $fields (keys %{$function_info[$keys]})
|
|
{
|
|
gp_message ("debugXL", $subr_name,"$keys $fields $function_info[$keys]{$fields}");
|
|
}
|
|
}
|
|
|
|
for my $i (keys %addressobjtextm)
|
|
{
|
|
gp_message ("debugXL", $subr_name,"addressobjtextm{$i} = $addressobjtextm{$i}");
|
|
}
|
|
|
|
gp_message ("verbose", $subr_name, "Generate the files with function overviews and the callers-callees information");
|
|
|
|
$script_pc_metrics = generate_function_level_info (\@exp_dir_list,
|
|
$call_metrics,
|
|
$summary_metrics,
|
|
$outputdir,
|
|
$sort_fields_ref);
|
|
|
|
gp_message ("verbose", $subr_name, "Preprocess the files with the function level information");
|
|
|
|
$ignore_value = preprocess_function_files (
|
|
$metric_description_ref,
|
|
$script_pc_metrics,
|
|
$outputdir,
|
|
\@sort_fields);
|
|
|
|
gp_message ("verbose", $subr_name, "For each function, generate a set of files");
|
|
|
|
($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = process_function_files (
|
|
\@exp_dir_list,
|
|
$executable_name,
|
|
$time_percentage_multiplier,
|
|
$summary_metrics,
|
|
$process_all_functions,
|
|
$elf_loadobjects_found,
|
|
$outputdir,
|
|
\@sort_fields,
|
|
\@function_info,
|
|
\%function_address_and_index,
|
|
\%LINUX_vDSO,
|
|
\%metric_description,
|
|
$elf_arch,
|
|
$base_va_executable,
|
|
$ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, \%elf_rats);
|
|
|
|
@function_info = @{ $function_info_ref };
|
|
%function_address_info = %{ $function_address_info_ref };
|
|
%addressobj_index = %{ $addressobj_index_ref };
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# Parse the disassembly information and generate the html files.
|
|
#-------------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Parse the disassembly files and generate the html files");
|
|
|
|
$ignore_value = parse_dis_files (\$number_of_metrics, \@function_info,
|
|
\%function_address_and_index,
|
|
\$outputdir, \%addressobj_index);
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# Parse the source information and generate the html files.
|
|
#-------------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Parse the source files and generate the html files");
|
|
|
|
parse_source_files (\$number_of_metrics, \@function_info, \$outputdir);
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# Parse the caller-callee information and generate the html files.
|
|
#-------------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Process the caller-callee information and generate the html file");
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# Generate the caller-callee information.
|
|
#-------------------------------------------------------------------------------------
|
|
$ignore_value = generate_caller_callee (
|
|
\$number_of_metrics,
|
|
\@function_info,
|
|
\%function_view_structure,
|
|
\%function_address_info,
|
|
\%addressobjtextm,
|
|
\$outputdir);
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# Parse the calltree information and generate the html files.
|
|
#-------------------------------------------------------------------------------------
|
|
if ($g_user_settings{"calltree"}{"current_value"} eq "on")
|
|
{
|
|
my $msg = "Process the call tree information and generate the html file";
|
|
gp_message ("verbose", $subr_name, $msg);
|
|
|
|
$ignore_value = process_calltree (
|
|
\@function_info,
|
|
\%function_address_info,
|
|
\%addressobjtextm,
|
|
$outputdir);
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# TBD
|
|
#-------------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Generate the html file with the metrics information");
|
|
|
|
$ignore_value = process_metrics (
|
|
$outputdir,
|
|
\@sort_fields,
|
|
\%metric_description,
|
|
\%ignored_metrics);
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# Generate the function view html files.
|
|
#-------------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Generate the function view html files");
|
|
|
|
$html_first_metric_file_ref = generate_function_view (
|
|
\$outputdir,
|
|
\$summary_metrics,
|
|
\$number_of_metrics,
|
|
\@function_info,
|
|
\%function_view_structure,
|
|
\%function_address_info,
|
|
\@sort_fields,
|
|
\@exp_dir_list,
|
|
\%addressobjtextm);
|
|
|
|
$html_first_metric_file = ${ $html_first_metric_file_ref };
|
|
|
|
gp_message ("debugXL", $subr_name, "html_first_metric_file = $html_first_metric_file");
|
|
|
|
my $html_test = ${ generate_home_link ("left") };
|
|
gp_message ("debugXL", $subr_name, "html_test = $html_test");
|
|
|
|
my $number_of_warnings_ref = create_html_warnings_page (\$outputdir);
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# Generate the index.html file.
|
|
#-------------------------------------------------------------------------------------
|
|
gp_message ("verbose", $subr_name, "Generate the index.html file");
|
|
|
|
$ignore_value = generate_index (\$outputdir,
|
|
\$html_first_metric_file,
|
|
\$summary_metrics,
|
|
\$number_of_metrics,
|
|
\@function_info,
|
|
\%function_address_info,
|
|
\@sort_fields,
|
|
\@exp_dir_list,
|
|
\%addressobjtextm,
|
|
\%metric_description_reversed,
|
|
$number_of_warnings_ref,
|
|
\@table_execution_stats);
|
|
|
|
#-------------------------------------------------------------------------------------
|
|
# We're done. In debug mode, print the meta data for the experiment directories.
|
|
#-------------------------------------------------------------------------------------
|
|
$ignore_value = print_meta_data_experiments ("debug");
|
|
|
|
my $results_file = $abs_path_outputdir . "/index.html";
|
|
my $prologue_text = "Processing completed - view file $results_file in a browser";
|
|
gp_message ("diag", $subr_name, $prologue_text);
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine main
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print a message after a failure in $GP_DISPLAY_TEXT.
|
|
#------------------------------------------------------------------------------
|
|
sub msg_display_text_failure
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($gp_display_text_cmd, $error_code, $error_file) = @_;
|
|
|
|
my $msg;
|
|
|
|
$msg = "error code = $error_code - failure executing the following command:";
|
|
gp_message ("error", $subr_name, $msg);
|
|
|
|
gp_message ("error", $subr_name, $gp_display_text_cmd);
|
|
|
|
$msg = "check file $error_file for more details";
|
|
gp_message ("error", $subr_name, $msg);
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine msg_display_text_failure
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If it is not present, add a "/" to the name of the argument. This is
|
|
# intended to be used for the name of the output directory and makes it
|
|
# easier to construct pathnames.
|
|
#------------------------------------------------------------------------------
|
|
sub append_forward_slash
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_string) = @_;
|
|
|
|
my $length_of_string = length ($input_string);
|
|
my $return_string = $input_string;
|
|
|
|
if (rindex ($input_string, "/") != $length_of_string-1)
|
|
{
|
|
$return_string .= "/";
|
|
}
|
|
|
|
return ($return_string);
|
|
|
|
} #-- End of subroutine append_forward_slash
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Return a string with a comma separated list of directory names.
|
|
#------------------------------------------------------------------------------
|
|
sub build_pretty_dir_list
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($dir_list_ref) = @_;
|
|
|
|
my @dir_list = @{ $dir_list_ref};
|
|
|
|
my $pretty_dir_list = join ("\n", @dir_list);
|
|
|
|
return ($pretty_dir_list);
|
|
|
|
} #-- End of subroutine build_pretty_dir_list
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Calculate the target address in hex by adding the instruction to the
|
|
# instruction address.
|
|
#------------------------------------------------------------------------------
|
|
sub calculate_target_hex_address
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($instruction_address, $instruction_offset) = @_;
|
|
|
|
my $dec_branch_target;
|
|
my $d1;
|
|
my $d2;
|
|
my $first_char;
|
|
my $length_of_string;
|
|
my $mask;
|
|
my $number_of_fields;
|
|
my $raw_hex_branch_target;
|
|
my $result;
|
|
|
|
if ($g_addressing_mode eq "64 bit")
|
|
{
|
|
$mask = "0xffffffffffffffff";
|
|
$number_of_fields = 16;
|
|
}
|
|
else
|
|
{
|
|
gp_message ("abort", $subr_name, "g_addressing_mode = $g_addressing_mode not supported\n");
|
|
}
|
|
|
|
$length_of_string = length ($instruction_offset);
|
|
$first_char = lcfirst (substr ($instruction_offset,0,1));
|
|
$d1 = bigint::hex ($instruction_offset);
|
|
$d2 = bigint::hex ($mask);
|
|
# if ($first_char eq "f")
|
|
if (($first_char =~ /[89a-f]/) and ($length_of_string == $number_of_fields))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The offset is negative. Convert to decimal and perform the subtrraction.
|
|
#------------------------------------------------------------------------------
|
|
#------------------------------------------------------------------------------
|
|
# XOR the decimal representation and add 1 to the result.
|
|
#------------------------------------------------------------------------------
|
|
$result = ($d1 ^ $d2) + 1;
|
|
$dec_branch_target = bigint::hex ($instruction_address) - $result;
|
|
}
|
|
else
|
|
{
|
|
$result = $d1;
|
|
$dec_branch_target = bigint::hex ($instruction_address) + $result;
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Convert to hexadecimal.
|
|
#------------------------------------------------------------------------------
|
|
$raw_hex_branch_target = sprintf ("%x", $dec_branch_target);
|
|
|
|
return ($raw_hex_branch_target);
|
|
|
|
} #-- End of subroutine calculate_target_hex_address
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Sets the absolute path to all commands in array @cmds. The commands and
|
|
# their respective paths are stored in hash "g_mapped_cmds".
|
|
#
|
|
# If no such mapping is found, a warning is issued, but execution continues.
|
|
# The warning(s) may help with troubleshooting, should a failure occur later.
|
|
#------------------------------------------------------------------------------
|
|
sub check_and_define_cmds
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($cmds_ref, $search_path_ref) = @_;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Dereference the array addressess first and then store the contents.
|
|
#------------------------------------------------------------------------------
|
|
my @cmds = @{$cmds_ref};
|
|
my @search_path = @{$search_path_ref};
|
|
|
|
my $found_match;
|
|
my $target_cmd;
|
|
my $failed_cmd;
|
|
my $no_of_failed_mappings;
|
|
my $failed_cmds;
|
|
|
|
gp_message ("debug", $subr_name, "\@cmds = @cmds");
|
|
gp_message ("debug", $subr_name, "\@search_path = @search_path");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Search for the command to be in the search path given. In case no such path
|
|
# can be found, the entry in $g_mapped_cmds is assigned a special value that
|
|
# will be checked for in the next block.
|
|
#------------------------------------------------------------------------------
|
|
for my $cmd (@cmds)
|
|
{
|
|
$found_match = $FALSE;
|
|
for my $path (@search_path)
|
|
{
|
|
$target_cmd = $path . "/" . $cmd;
|
|
if (-x $target_cmd)
|
|
{
|
|
$found_match = $TRUE;
|
|
$g_mapped_cmds{$cmd} = $target_cmd;
|
|
last;
|
|
}
|
|
}
|
|
|
|
if (not $found_match)
|
|
{
|
|
$g_mapped_cmds{$cmd} = "road_to_nowhere";
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Scan the results stored in $g_mapped_cmds and flag errors.
|
|
#------------------------------------------------------------------------------
|
|
$no_of_failed_mappings = 0;
|
|
$failed_cmds = "";
|
|
while ( my ($cmd, $mapped) = each %g_mapped_cmds)
|
|
{
|
|
if ($mapped eq "road_to_nowhere")
|
|
{
|
|
my $msg = "cannot find a path for command $cmd - " .
|
|
"assume this will still work without a path";
|
|
gp_message ("warning", $subr_name, $msg);
|
|
$no_of_failed_mappings++;
|
|
$failed_cmds .= $cmd;
|
|
$g_mapped_cmds{$cmd} = $cmd;
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "path for the $cmd command is $mapped");
|
|
}
|
|
}
|
|
if ($no_of_failed_mappings != 0)
|
|
{
|
|
gp_message ("debug", $subr_name, "failed to find a mapping for $failed_cmds");
|
|
gp_message ("debug", $subr_name, "a total of $no_of_failed_mappings mapping failures");
|
|
}
|
|
|
|
return ($no_of_failed_mappings);
|
|
|
|
} #-- End of subroutine check_and_define_cmds
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Look for a branch instruction, or the special endbr32/endbr64 instruction
|
|
# that is also considered to be a branch target. Note that the latter is x86
|
|
# specific.
|
|
#------------------------------------------------------------------------------
|
|
sub check_and_proc_dis_branches
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_line_ref, $line_no_ref, $branch_target_ref,
|
|
$extended_branch_target_ref, $branch_target_no_ref_ref) = @_;
|
|
|
|
my $input_line = ${ $input_line_ref };
|
|
my $line_no = ${ $line_no_ref };
|
|
my %branch_target = %{ $branch_target_ref };
|
|
my %extended_branch_target = %{ $extended_branch_target_ref };
|
|
my %branch_target_no_ref = %{ $branch_target_no_ref_ref };
|
|
|
|
my $found_it = $TRUE;
|
|
my $hex_branch_target;
|
|
my $instruction_address;
|
|
my $instruction_offset;
|
|
my $msg;
|
|
my $raw_hex_branch_target;
|
|
|
|
if ( ($input_line =~ /$g_branch_regex/)
|
|
or ($input_line =~ /$g_endbr_regex/))
|
|
{
|
|
if (defined ($3))
|
|
{
|
|
$msg = "found a branch or endbr instruction: " .
|
|
"\$1 = $1 \$2 = $2 \$3 = $3";
|
|
}
|
|
else
|
|
{
|
|
$msg = "found a branch or endbr instruction: " .
|
|
"\$1 = $1 \$2 = $2";
|
|
}
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
if (defined ($1))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Found a qualifying instruction
|
|
#------------------------------------------------------------------------------
|
|
$instruction_address = $1;
|
|
if (defined ($3))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# This must be the branch target and needs to be converted and processed.
|
|
#------------------------------------------------------------------------------
|
|
$instruction_offset = $3;
|
|
$raw_hex_branch_target = calculate_target_hex_address (
|
|
$instruction_address,
|
|
$instruction_offset);
|
|
|
|
$hex_branch_target = "0x" . $raw_hex_branch_target;
|
|
$branch_target{$hex_branch_target} = 1;
|
|
$extended_branch_target{$instruction_address} = $raw_hex_branch_target;
|
|
}
|
|
if (defined ($2) and (not defined ($3)))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Unlike a branch, the endbr32/endbr64 instructions do not have a second field.
|
|
#------------------------------------------------------------------------------
|
|
my $instruction_name = $2;
|
|
if ($instruction_name =~ /$g_endbr_inst_regex/)
|
|
{
|
|
my $msg = "found endbr: $instruction_name " .
|
|
$instruction_address;
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
$raw_hex_branch_target = $instruction_address;
|
|
|
|
$hex_branch_target = "0x" . $raw_hex_branch_target;
|
|
$branch_target_no_ref{$instruction_address} = 1;
|
|
}
|
|
}
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Perhaps this should be an assertion or alike.
|
|
#------------------------------------------------------------------------------
|
|
$branch_target{"0x0000"} = $FALSE;
|
|
gp_message ("debug", $subr_name, "cannot determine branch target");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$found_it = $FALSE;
|
|
}
|
|
|
|
return (\$found_it, \%branch_target, \%extended_branch_target,
|
|
\%branch_target_no_ref);
|
|
|
|
} #-- End of subroutine check_and_proc_dis_branches
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check an input line from the disassembly file to include a function call.
|
|
# If it does, process the line and return the branch target results.
|
|
#------------------------------------------------------------------------------
|
|
sub check_and_proc_dis_func_call
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_line_ref, $line_no_ref, $branch_target_ref,
|
|
$extended_branch_target_ref) = @_;
|
|
|
|
my $input_line = ${ $input_line_ref };
|
|
my $line_no = ${ $line_no_ref };
|
|
my %branch_target = %{ $branch_target_ref };
|
|
my %extended_branch_target = %{ $extended_branch_target_ref };
|
|
|
|
my $found_it = $TRUE;
|
|
my $hex_branch_target;
|
|
my $instruction_address;
|
|
my $instruction_offset;
|
|
my $msg;
|
|
my $raw_hex_branch_target;
|
|
|
|
if ( $input_line =~ /$g_function_call_v2_regex/ )
|
|
{
|
|
$msg = "found a function call - line[$line_no] = $input_line";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
if (not defined ($2))
|
|
{
|
|
$msg = "line[$line_no] " .
|
|
"an instruction address is expected, but not found";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
else
|
|
{
|
|
$instruction_address = $2;
|
|
|
|
$msg = "instruction_address = $instruction_address";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
if (not defined ($4))
|
|
{
|
|
$msg = "line[$line_no] " .
|
|
"an address offset is expected, but not found";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
else
|
|
{
|
|
$instruction_offset = $4;
|
|
if ($instruction_offset =~ /[0-9a-fA-F]+/)
|
|
{
|
|
$msg = "calculate branch target: " .
|
|
"instruction_address = $instruction_address";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
$msg = "calculate branch target: " .
|
|
"instruction_offset = $instruction_offset";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The instruction offset needs to be converted and added to the instruction
|
|
# address.
|
|
#------------------------------------------------------------------------------
|
|
$raw_hex_branch_target = calculate_target_hex_address (
|
|
$instruction_address,
|
|
$instruction_offset);
|
|
$hex_branch_target = "0x" . $raw_hex_branch_target;
|
|
|
|
$msg = "calculated hex_branch_target = " .
|
|
$hex_branch_target;
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
$branch_target{$hex_branch_target} = 1;
|
|
$extended_branch_target{$instruction_address} = $raw_hex_branch_target;
|
|
|
|
$msg = "set branch_target{$hex_branch_target} to 1";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
$msg = "added extended_branch_target{$instruction_address}" .
|
|
" = $extended_branch_target{$instruction_address}";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
else
|
|
{
|
|
$msg = "line[$line_no] unknown address format";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$found_it = $FALSE;
|
|
}
|
|
|
|
return (\$found_it, \%branch_target, \%extended_branch_target);
|
|
|
|
} #-- End of subroutine check_and_proc_dis_func_call
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool
|
|
# needed to provide the information. If it can not be found, execution is
|
|
# terminated.
|
|
#
|
|
# We first search foe this tool in the current execution directory. If it
|
|
# cannot be found there, use $PATH to try to locate it.
|
|
#------------------------------------------------------------------------------
|
|
sub check_availability_tool
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($location_gp_command_ref) = @_;
|
|
|
|
my $error_code;
|
|
my $error_occurred;
|
|
my $msg;
|
|
my $output_which_gp_display_text;
|
|
my $return_value;
|
|
my $target_cmd;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the path to gp-display-text.
|
|
#------------------------------------------------------------------------------
|
|
my ($error_occurred_ref, $return_value_ref) = find_path_to_gp_display_text (
|
|
$location_gp_command_ref
|
|
);
|
|
$error_occurred = ${ $error_occurred_ref};
|
|
$return_value = ${ $return_value_ref};
|
|
|
|
$msg = "error_occurred = $error_occurred return_value = $return_value";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
if (not $error_occurred)
|
|
#------------------------------------------------------------------------------
|
|
# All is well and gp-display-text has been located.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$g_path_to_tools = $return_value;
|
|
|
|
$msg = "located $GP_DISPLAY_TEXT in execution directory";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
$msg = "g_path_to_tools = $g_path_to_tools";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# Something went wrong, but perhaps we can still continue. Try to find
|
|
# $GP_DISPLAY_TEXT through the search path.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$msg = "error accessing $GP_DISPLAY_TEXT: $return_value - " .
|
|
"run time behaviour may be undefined";
|
|
gp_message ("warning", $subr_name, $msg);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if we can find $GP_DISPLAY_TEXT in the search path.
|
|
#------------------------------------------------------------------------------
|
|
$msg = "check for $GP_DISPLAY_TEXT in search path";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
|
|
$target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1";
|
|
|
|
($error_code, $output_which_gp_display_text) =
|
|
execute_system_cmd ($target_cmd);
|
|
|
|
if ($error_code == 0)
|
|
{
|
|
my ($gp_file_name, $gp_path, $suffix_not_used) =
|
|
fileparse ($output_which_gp_display_text);
|
|
$g_path_to_tools = $gp_path;
|
|
|
|
$msg = "using $GP_DISPLAY_TEXT in $g_path_to_tools instead";
|
|
gp_message ("warning", $subr_name, $msg);
|
|
|
|
$msg = "the $GP_DISPLAY_TEXT tool is in the search path";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
$msg = "g_path_to_tools = $g_path_to_tools";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
}
|
|
else
|
|
{
|
|
$msg = "failure to find $GP_DISPLAY_TEXT in the search path";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
|
|
$msg = "fatal error executing command $target_cmd";
|
|
gp_message ("abort", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
return (\$g_path_to_tools);
|
|
|
|
} #-- End of subroutine check_availability_tool
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This function determines whether load objects are in ELF format.
|
|
#
|
|
# Compared to the original code, any input value other than 2 or 3 is rejected
|
|
# upfront. This not only reduces the nesting level, but also eliminates a
|
|
# possible bug.
|
|
#
|
|
# Also, by isolating the tests for the input files, another nesting level could
|
|
# be eliminated, further simplifying this still too complex code.
|
|
#------------------------------------------------------------------------------
|
|
sub check_loadobjects_are_elf
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($selected_archive) = @_;
|
|
|
|
my $hostname_current = $local_system_config{"hostname_current"};
|
|
my $arch = $local_system_config{"processor"};
|
|
my $arch_uname_s = $local_system_config{"kernel_name"};
|
|
|
|
my $extracted_information;
|
|
|
|
my $elf_magic_number;
|
|
|
|
my $executable_name;
|
|
my $va_executable_in_hex;
|
|
|
|
my $arch_exp;
|
|
my $hostname_exp;
|
|
my $os_exp;
|
|
my $os_exp_full;
|
|
|
|
my $archives_file;
|
|
my $rc_b;
|
|
my $file;
|
|
my $line;
|
|
my $name;
|
|
my $name_path;
|
|
my $foffset;
|
|
my $vaddr;
|
|
my $modes;
|
|
|
|
my $path_to_map_file;
|
|
my $path_to_log_file;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Parameterize and should be the first experiment directory from the list.
|
|
#------------------------------------------------------------------------------
|
|
$path_to_log_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
|
|
$path_to_log_file .= $selected_archive;
|
|
$path_to_log_file .= "/log.xml";
|
|
|
|
gp_message ("debug", $subr_name, "hostname_current = $hostname_current");
|
|
gp_message ("debug", $subr_name, "arch = $arch");
|
|
gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#
|
|
# This check can probably be removed since the presence of the log.xml file is
|
|
# checked for in an earlier phase.
|
|
#------------------------------------------------------------------------------
|
|
open (LOG_XML, "<", $path_to_log_file)
|
|
or die ("$subr_name - unable to open file $path_to_log_file for reading: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $path_to_log_file for reading");
|
|
|
|
while (<LOG_XML>)
|
|
{
|
|
$line = $_;
|
|
chomp ($line);
|
|
gp_message ("debug", $subr_name, "read line: $line");
|
|
#------------------------------------------------------------------------------
|
|
# Search for the first line starting with "<system". Bail out if found and
|
|
# parsed. These are two examples:
|
|
# <system hostname="ruud-vm" arch="x86_64" os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514">
|
|
# <system hostname="sca-m88-092-pd0" arch="sun4v" os="SunOS 5.11" pagesz="8192" npages="602963968">
|
|
#------------------------------------------------------------------------------
|
|
if ($line =~ /^\s*<system\s+/)
|
|
{
|
|
gp_message ("debug", $subr_name, "selected the following line from the log.xml file:");
|
|
gp_message ("debug", $subr_name, "$line");
|
|
if ($line =~ /.*\s+hostname="([^"]+)/)
|
|
{
|
|
$hostname_exp = $1;
|
|
gp_message ("debug", $subr_name, "extracted hostname_exp = $hostname_exp");
|
|
}
|
|
if ($line =~ /.*\s+arch="([^"]+)/)
|
|
{
|
|
$arch_exp = $1;
|
|
gp_message ("debug", $subr_name, "extracted arch_exp = $arch_exp");
|
|
}
|
|
if ($line =~ /.*\s+os="([^"]+)/)
|
|
{
|
|
$os_exp_full = $1;
|
|
#------------------------------------------------------------------------------
|
|
# Capture the first word only.
|
|
#------------------------------------------------------------------------------
|
|
if ($os_exp_full =~ /([^\s]+)/)
|
|
{
|
|
$os_exp = $1;
|
|
}
|
|
gp_message ("debug", $subr_name, "extracted os_exp = $os_exp");
|
|
}
|
|
last;
|
|
}
|
|
} #-- End of while loop
|
|
|
|
close (LOG_XML);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If the current system is identical to the system used in the experiment,
|
|
# we can return early. Otherwise we need to dig deeper.
|
|
#
|
|
# TBD: How about the other experiment directories?! This needs to be fixed.
|
|
#------------------------------------------------------------------------------
|
|
|
|
gp_message ("debug", $subr_name, "completed while loop");
|
|
gp_message ("debug", $subr_name, "hostname_exp = $hostname_exp");
|
|
gp_message ("debug", $subr_name, "arch_exp = $arch_exp");
|
|
gp_message ("debug", $subr_name, "os_exp = $os_exp");
|
|
|
|
#TBD: THIS DOES NOT CHECK IF ELF IS FOUND!
|
|
|
|
if (($hostname_current eq $hostname_exp) and
|
|
($arch eq $arch_exp) and
|
|
($arch_uname_s eq $os_exp))
|
|
{
|
|
gp_message ("debug", $subr_name, "early return: the hostname, architecture and OS match the current system");
|
|
gp_message ("debug", $subr_name, "FAKE THIS IS NOT THE CASE AND CONTINUE");
|
|
# FAKE return ($TRUE);
|
|
}
|
|
|
|
if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"})
|
|
{
|
|
gp_message ("debug", $subr_name, "selected_archive = $selected_archive");
|
|
for my $i (sort keys %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}})
|
|
{
|
|
gp_message ("debug", $subr_name, "stored loadobject $i $g_exp_dir_meta_data{$selected_archive}{'archive_files'}{$i}");
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the selected experiment directory has archived files in ELF format.
|
|
# If not, use the information in map.xml to get the name of the executable
|
|
# and the virtual address.
|
|
#------------------------------------------------------------------------------
|
|
|
|
if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"})
|
|
{
|
|
gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are in ELF format");
|
|
gp_message ("debug", $subr_name, "IGNORE THIS AND USE MAP.XML");
|
|
## return ($TRUE);
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are not in ELF format");
|
|
|
|
$path_to_map_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
|
|
$path_to_map_file .= $selected_archive;
|
|
$path_to_map_file .= "/map.xml";
|
|
|
|
open (MAP_XML, "<", $path_to_map_file)
|
|
or die ($subr_name, "unable to open file $path_to_map_file for reading: $!");
|
|
gp_message ("debug", $subr_name, "opened file $path_to_map_file for reading");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Scan the map.xml file. We need to find the name of the executable with the
|
|
# mode set to 0x005. For this entry we have to capture the virtual address.
|
|
#------------------------------------------------------------------------------
|
|
$extracted_information = $FALSE;
|
|
while (<MAP_XML>)
|
|
{
|
|
$line = $_;
|
|
chomp ($line);
|
|
gp_message ("debug", $subr_name, "MAP_XML read line = $line");
|
|
## if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+ .*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
|
|
if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
|
|
{
|
|
gp_message ("debug", $subr_name, "target line = $line");
|
|
$vaddr = $1;
|
|
$foffset = $2;
|
|
$modes = $3;
|
|
$name_path = $4;
|
|
$name = get_basename ($name_path);
|
|
gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes");
|
|
gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name");
|
|
# $error_extracting_information = $TRUE;
|
|
$executable_name = $name;
|
|
my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset);
|
|
my $hex_VA = sprintf ("0x%016x", $result_VA);
|
|
$va_executable_in_hex = $hex_VA;
|
|
gp_message ("debug", $subr_name, "set executable_name = $executable_name");
|
|
gp_message ("debug", $subr_name, "set va_executable_in_hex = $va_executable_in_hex");
|
|
gp_message ("debug", $subr_name, "result_VA = $result_VA");
|
|
gp_message ("debug", $subr_name, "hex_VA = $hex_VA");
|
|
if ($modes eq "005")
|
|
{
|
|
$extracted_information = $TRUE;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
if (not $extracted_information)
|
|
{
|
|
my $msg = "cannot find the necessary information in the $path_to_map_file file";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
## $executable_name = $ARCHIVES_MAP_NAME;
|
|
## $va_executable_in_hex = $ARCHIVES_MAP_VADDR;
|
|
|
|
return ($executable_name, $va_executable_in_hex);
|
|
|
|
} #-- End of subroutine check_loadobjects_are_elf
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Compare the current metric values against the maximum values. Mark the line
|
|
# if a value is within the percentage defined by $hp_value.
|
|
#------------------------------------------------------------------------------
|
|
sub check_metric_values
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($metric_values, $max_metric_values_ref) = @_;
|
|
|
|
my @max_metric_values = @{ $max_metric_values_ref };
|
|
|
|
my @current_metrics = ();
|
|
my $colour_coded_line;
|
|
my $current_value;
|
|
my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
|
|
my $max_value;
|
|
my $relative_distance;
|
|
|
|
@current_metrics = split (" ", $metric_values);
|
|
$colour_coded_line = $FALSE;
|
|
for my $metric (0 .. $#current_metrics)
|
|
{
|
|
$current_value = $current_metrics[$metric];
|
|
if (exists ($max_metric_values[$metric]))
|
|
{
|
|
$max_value = $max_metric_values[$metric];
|
|
gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
|
|
if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) )
|
|
{
|
|
# TBD: abs needed?
|
|
gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
|
|
$relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value );
|
|
gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance");
|
|
if ($relative_distance >= $hp_value/100.0)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance");
|
|
$colour_coded_line = $TRUE;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
} #-- End of loop over metrics
|
|
|
|
return (\$colour_coded_line);
|
|
|
|
} #-- End of subroutine check_metric_values
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the system is supported.
|
|
#------------------------------------------------------------------------------
|
|
sub check_support_for_processor
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($machine_ref) = @_;
|
|
|
|
my $machine = ${ $machine_ref };
|
|
my $is_supported;
|
|
|
|
if ($machine eq "x86_64")
|
|
{
|
|
$is_supported = $TRUE;
|
|
}
|
|
else
|
|
{
|
|
$is_supported = $FALSE;
|
|
}
|
|
|
|
return (\$is_supported);
|
|
|
|
} #-- End of subroutine check_support_for_processor
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the value for the user option given is valid.
|
|
#
|
|
# In case the value is valid, the g_user_settings table is updated.
|
|
# Otherwise an error message is printed.
|
|
#
|
|
# The return value is TRUE/FALSE.
|
|
#------------------------------------------------------------------------------
|
|
sub check_user_option
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($internal_option_name, $value) = @_;
|
|
|
|
my $message;
|
|
my $return_value;
|
|
|
|
my $option = $g_user_settings{$internal_option_name}{"option"};
|
|
my $data_type = $g_user_settings{$internal_option_name}{"data_type"};
|
|
my $no_of_arguments = $g_user_settings{$internal_option_name}{"no_of_arguments"};
|
|
|
|
if (($no_of_arguments >= 1) and
|
|
((not defined ($value)) or (length ($value) == 0)))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# If there was no value given, but it is required, flag an error.
|
|
# There could also be a value, but it might be the empty string.
|
|
#
|
|
# Note that that there are currently no options with multiple values. Should
|
|
# these be introduced, the current check may need to be refined.
|
|
#------------------------------------------------------------------------------
|
|
|
|
$message = "the $option option requires a value";
|
|
push (@g_user_input_errors, $message);
|
|
$return_value = $FALSE;
|
|
}
|
|
elsif ($no_of_arguments >= 1)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# There is an input value. Check if it is valid and if so, store it.
|
|
#
|
|
# Note that we allow the options to be case insensitive.
|
|
#------------------------------------------------------------------------------
|
|
my $valid = verify_if_input_is_valid ($value, $data_type);
|
|
|
|
if ($valid)
|
|
{
|
|
if (($data_type eq "onoff") or ($data_type eq "size"))
|
|
{
|
|
$g_user_settings{$internal_option_name}{"current_value"} = lc ($value);
|
|
}
|
|
else
|
|
{
|
|
$g_user_settings{$internal_option_name}{"current_value"} = $value;
|
|
}
|
|
$g_user_settings{$internal_option_name}{"defined"} = $TRUE;
|
|
$return_value = $TRUE;
|
|
}
|
|
else
|
|
{
|
|
$message = "incorrect value for $option option: $value";
|
|
push (@g_user_input_errors, $message);
|
|
|
|
$return_value = $FALSE;
|
|
}
|
|
}
|
|
|
|
return ($return_value);
|
|
|
|
} #-- End of subroutine check_user_option
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# This subroutine performs multiple checks on the experiment directories. One
|
|
# or more failures are fatal.
|
|
#-------------------------------------------------------------------------------
|
|
sub check_validity_exp_dirs
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($exp_dir_list_ref) = @_;
|
|
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
|
|
my %elf_rats = ();
|
|
|
|
my $dir_not_found = $FALSE;
|
|
my $invalid_dir = $FALSE;
|
|
my $dir_check_errors = $FALSE;
|
|
my $missing_dirs = 0;
|
|
my $invalid_dirs = 0;
|
|
|
|
my $archive_dir_not_empty;
|
|
my $elf_magic_number;
|
|
my $archives_file;
|
|
my $archives_dir;
|
|
my $first_line;
|
|
my $count_exp_dir_not_elf;
|
|
|
|
my $first_time;
|
|
my $filename;
|
|
|
|
my $comment;
|
|
|
|
my $selected_archive_has_elf_format;
|
|
|
|
my $selected_archive;
|
|
my $archive_dir_selected;
|
|
my $no_of_files_in_selected_archive;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Check if the experiment directories exist and are valid.
|
|
#-------------------------------------------------------------------------------
|
|
for my $exp_dir (@exp_dir_list)
|
|
{
|
|
if (not -d $exp_dir)
|
|
{
|
|
$dir_not_found = $TRUE;
|
|
$missing_dirs++;
|
|
gp_message ("error", $subr_name, "directory $exp_dir not found");
|
|
$dir_check_errors = $TRUE;
|
|
}
|
|
else
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# Files log.xml and map.xml have to be there.
|
|
#-------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "directory $exp_dir found");
|
|
if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml"))
|
|
{
|
|
gp_message ("debug", $subr_name, "directory $exp_dir appears to be a valid experiment directory");
|
|
}
|
|
else
|
|
{
|
|
$invalid_dir = $TRUE;
|
|
$invalid_dirs++;
|
|
gp_message ("debug", $subr_name, "file ".$exp_dir."/log.xml and/or ".$exp_dir."/map.xml missing");
|
|
gp_message ("error" , $subr_name, "directory $exp_dir does not appear to be a valid experiment directory");
|
|
$dir_check_errors = $TRUE;
|
|
}
|
|
}
|
|
}
|
|
if ($dir_not_found)
|
|
{
|
|
gp_message ("error", $subr_name, "a total of $missing_dirs directories not found");
|
|
}
|
|
if ($invalid_dir)
|
|
{
|
|
gp_message ("abort", $subr_name, "a total of $invalid_dirs directories are not valid");
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Initialize ELF status to FALSE.
|
|
#-------------------------------------------------------------------------------
|
|
## for my $exp_dir (@exp_dir_list)
|
|
for my $exp_dir (keys %g_exp_dir_meta_data)
|
|
{
|
|
$g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE;
|
|
$g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
|
|
}
|
|
#-------------------------------------------------------------------------------
|
|
# Check if the load objects are in ELF format.
|
|
#-------------------------------------------------------------------------------
|
|
for my $exp_dir (keys %g_exp_dir_meta_data)
|
|
{
|
|
$archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives";
|
|
$archive_dir_not_empty = $FALSE;
|
|
$first_time = $TRUE;
|
|
$g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE;
|
|
$g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0;
|
|
|
|
gp_message ("debug", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
|
|
gp_message ("debug", $subr_name, "checking $archives_dir");
|
|
|
|
while (glob ("$archives_dir/*"))
|
|
{
|
|
$filename = get_basename ($_);
|
|
gp_message ("debug", $subr_name, "processing file: $filename");
|
|
|
|
$g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE;
|
|
$g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++;
|
|
|
|
$archive_dir_not_empty = $TRUE;
|
|
#-------------------------------------------------------------------------------
|
|
# Replaces the ELF_RATS part in elf_phdr.
|
|
#
|
|
# Challenge: splittable_mrg.c_I0txnOW_Wn5
|
|
#
|
|
# TBD: Store this for each relevant experiment directory.
|
|
#-------------------------------------------------------------------------------
|
|
my $last_dot = rindex ($filename,".");
|
|
my $underscore_before_dot = $TRUE;
|
|
my $first_underscore = -1;
|
|
gp_message ("debugXL", $subr_name, "last_dot = $last_dot");
|
|
while ($underscore_before_dot)
|
|
{
|
|
$first_underscore = index ($filename, "_", $first_underscore+1);
|
|
if ($last_dot < $first_underscore)
|
|
{
|
|
$underscore_before_dot = $FALSE;
|
|
}
|
|
}
|
|
my $original_name = substr ($filename, 0, $first_underscore);
|
|
gp_message ("debug", $subr_name, "stripped archive name: $original_name");
|
|
if (not exists ($elf_rats{$original_name}))
|
|
{
|
|
$elf_rats{$original_name} = [$filename, $exp_dir];
|
|
}
|
|
#-------------------------------------------------------------------------------
|
|
# We only need to detect the presence of an object once.
|
|
#-------------------------------------------------------------------------------
|
|
if ($first_time)
|
|
{
|
|
$first_time = $FALSE;
|
|
$g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE;
|
|
gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
|
|
}
|
|
}
|
|
} #-- End of loop over experiment directories
|
|
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
|
|
gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($empty ? "empty" : "not empty"));
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Verify that all relevant files in the archive directories are in ELF format.
|
|
#------------------------------------------------------------------------------
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
$g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
|
|
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
|
|
{
|
|
$archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives";
|
|
gp_message ("debug", $subr_name, "exp_dir = $exp_dir archives_dir = $archives_dir");
|
|
#------------------------------------------------------------------------------
|
|
# Check if any of the loadobjects is of type ELF. Bail out on the first one
|
|
# found. The assumption is that all other loadobjects must be of type ELF too
|
|
# then.
|
|
#------------------------------------------------------------------------------
|
|
for my $aname (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}})
|
|
{
|
|
$filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives/" . $aname;
|
|
open (ARCF,"<", $filename)
|
|
or die ("unable to open file $filename for reading - '$!'");
|
|
|
|
$first_line = <ARCF>;
|
|
close (ARCF);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The first 4 hex fields in the header of an ELF file are: 7F 45 4c 46 (7FELF).
|
|
#
|
|
# See also https://en.wikipedia.org/wiki/Executable_and_Linkable_Format
|
|
#------------------------------------------------------------------------------
|
|
# if ($first_line =~ /^\177ELF.*/)
|
|
|
|
$elf_magic_number = unpack ('H8', $first_line);
|
|
# gp_message ("debug", $subr_name, "elf_magic_number = $elf_magic_number");
|
|
if ($elf_magic_number eq "7f454c46")
|
|
{
|
|
$g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $TRUE;
|
|
$g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
$comment = "the loadobjects in the archive in $exp_dir are ";
|
|
$comment .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? "in " : "not in ";
|
|
$comment .= "ELF format";
|
|
gp_message ("debug", $subr_name, $comment);
|
|
}
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
|
|
{
|
|
gp_message ("debug", $subr_name, "there are no archived files in $exp_dir");
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If there are archived files and they are not in ELF format, a debug is
|
|
# issued.
|
|
#
|
|
# TBD: Bail out?
|
|
#------------------------------------------------------------------------------
|
|
$count_exp_dir_not_elf = 0;
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"})
|
|
{
|
|
$count_exp_dir_not_elf++;
|
|
}
|
|
}
|
|
if ($count_exp_dir_not_elf != 0)
|
|
{
|
|
gp_message ("debug", $subr_name, "there are $count_exp_dir_not_elf experiments with non-ELF load objects");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Select the experiment directory that is used for the files in the archive.
|
|
# By default, a directory with archived files is used, but in case this does
|
|
# not exist, a directory without archived files is selected. Obviously this
|
|
# needs to be dealt with later on.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Try the experiments with archived files first.
|
|
#------------------------------------------------------------------------------
|
|
$archive_dir_not_empty = $FALSE;
|
|
$archive_dir_selected = $FALSE;
|
|
## for my $exp_dir (sort @exp_dir_list)
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "exp_dir = $exp_dir");
|
|
gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}");
|
|
|
|
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
|
|
{
|
|
$selected_archive = $exp_dir;
|
|
$archive_dir_not_empty = $TRUE;
|
|
$archive_dir_selected = $TRUE;
|
|
$selected_archive_has_elf_format = ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? $TRUE : $FALSE;
|
|
last;
|
|
}
|
|
}
|
|
if (not $archive_dir_selected)
|
|
#------------------------------------------------------------------------------
|
|
# None are found and pick the first one without archived files.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
|
|
{
|
|
$selected_archive = $exp_dir;
|
|
$archive_dir_not_empty = $FALSE;
|
|
$archive_dir_selected = $TRUE;
|
|
$selected_archive_has_elf_format = $FALSE;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
gp_message ("debug", $subr_name, "experiment $selected_archive has been selected for archive analysis");
|
|
gp_message ("debug", $subr_name, "this archive is ". (($archive_dir_not_empty) ? "not empty" : "empty"));
|
|
gp_message ("debug", $subr_name, "this archive is ". (($selected_archive_has_elf_format) ? "in" : "not in")." ELF format");
|
|
#------------------------------------------------------------------------------
|
|
# Get the size of the hash that contains the archived files.
|
|
#------------------------------------------------------------------------------
|
|
## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES);
|
|
|
|
$no_of_files_in_selected_archive = $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"};
|
|
gp_message ("debug", $subr_name, "number of files in archive $selected_archive is $no_of_files_in_selected_archive");
|
|
|
|
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
|
|
gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($is_empty ? "empty" : "not empty"));
|
|
}
|
|
for my $exp_dir (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
|
|
{
|
|
for my $object (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}})
|
|
{
|
|
gp_message ("debug", $subr_name, "$exp_dir $object $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}");
|
|
}
|
|
}
|
|
}
|
|
|
|
return ($dir_check_errors, $archive_dir_not_empty, $selected_archive, \%elf_rats);
|
|
|
|
} #-- End of subroutine check_validity_exp_dirs
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Color the string and optionally mark it boldface.
|
|
#
|
|
# For supported colors, see:
|
|
# https://www.w3schools.com/colors/colors_names.asp
|
|
#------------------------------------------------------------------------------
|
|
sub color_string
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_string, $boldface, $color) = @_;
|
|
|
|
my $colored_string;
|
|
|
|
$colored_string = "<font color='" . $color . "'>";
|
|
|
|
if ($boldface)
|
|
{
|
|
$colored_string .= "<b>";
|
|
}
|
|
|
|
$colored_string .= $input_string;
|
|
|
|
if ($boldface)
|
|
{
|
|
$colored_string .= "</b>";
|
|
}
|
|
$colored_string .= "</font>";
|
|
|
|
return ($colored_string);
|
|
|
|
} #-- End of subroutine color_string
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the array with the info on the experiment(s).
|
|
#------------------------------------------------------------------------------
|
|
sub create_exp_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($experiment_dir_list_ref, $experiment_data_ref) = @_;
|
|
|
|
my @experiment_dir_list = @{ $experiment_dir_list_ref };
|
|
my @experiment_data = @{ $experiment_data_ref };
|
|
|
|
my @experiment_stats_html = ();
|
|
my $experiment_stats_line;
|
|
my $plural;
|
|
|
|
$plural = ($#experiment_dir_list > 0) ? "s:" : ":";
|
|
|
|
$experiment_stats_line = "<h3>\n";
|
|
$experiment_stats_line .= "Full pathnames to the input experiment" . $plural . "\n";
|
|
$experiment_stats_line .= "</h3>\n";
|
|
$experiment_stats_line .= "<pre>\n";
|
|
|
|
for my $i (0 .. $#experiment_dir_list)
|
|
{
|
|
$experiment_stats_line .= $experiment_dir_list[$i] . " (" . $experiment_data[$i]{"start_date"} . ")\n";
|
|
}
|
|
$experiment_stats_line .= "</pre>\n";
|
|
|
|
push (@experiment_stats_html, $experiment_stats_line);
|
|
|
|
gp_message ("debugXL", $subr_name, "experiment_stats_line = $experiment_stats_line --");
|
|
|
|
return (\@experiment_stats_html);
|
|
|
|
} #-- End of subroutine create_exp_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Trivial function to generate a tag. This has been made a function to ensure
|
|
# consistency creating tags and also make it easier to change them.
|
|
#------------------------------------------------------------------------------
|
|
sub create_function_tag
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($tag_id) = @_;
|
|
|
|
my $function_tag = "function_tag_" . $tag_id;
|
|
|
|
return ($function_tag);
|
|
|
|
} #-- End of subroutine create_function_tag
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate and return a string with the credits. Note that this also ends
|
|
# the HTML formatting controls.
|
|
#------------------------------------------------------------------------------
|
|
sub create_html_credits
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my $msg;
|
|
my $the_date;
|
|
|
|
my @months = qw (January February March April May June July August September October November December);
|
|
|
|
my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime ();
|
|
|
|
$year += 1900;
|
|
|
|
$the_date = $months[$mon] . " " . $mday . ", " . $year;
|
|
|
|
$msg = "<i>\n";
|
|
$msg .= "Output generated by the $driver_cmd command ";
|
|
$msg .= "on $the_date ";
|
|
$msg .= "(GNU binutils version " . $binutils_version . ")";
|
|
$msg .= "\n";
|
|
$msg .= "</i>";
|
|
|
|
gp_message ("debug", $subr_name, "the date = $the_date");
|
|
|
|
return (\$msg);
|
|
|
|
} #-- End of subroutine create_html_credits
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate a string that contains all the necessary HTML header information,
|
|
# plus a title.
|
|
#
|
|
# See also https://www.w3schools.com for the details on the features used.
|
|
#------------------------------------------------------------------------------
|
|
sub create_html_header
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($title_ref) = @_;
|
|
|
|
my $title = ${ $title_ref };
|
|
|
|
my $LANG = $g_locale_settings{"LANG"};
|
|
my $background_color = $g_html_color_scheme{"background_color_page"};
|
|
|
|
my $html_header;
|
|
|
|
$html_header = "<!DOCTYPE html public \"-//w3c//dtd html 3.2//en\">\n";
|
|
$html_header .= "<html lang=\"$LANG\">\n";
|
|
$html_header .= "<head>\n";
|
|
$html_header .= "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n";
|
|
$html_header .= "<title>" . $title . "</title>\n";
|
|
$html_header .= "</head>\n";
|
|
$html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n";
|
|
$html_header .= "<style>\n";
|
|
$html_header .= "div.left {\n";
|
|
$html_header .= "text-align: left;\n";
|
|
$html_header .= "}\n";
|
|
$html_header .= "div.right {\n";
|
|
$html_header .= "text-align: right;\n";
|
|
$html_header .= "}\n";
|
|
$html_header .= "div.center {\n";
|
|
$html_header .= "text-align: center;\n";
|
|
$html_header .= "}\n";
|
|
$html_header .= "div.justify {\n";
|
|
$html_header .= "text-align: justify;\n";
|
|
$html_header .= "}\n";
|
|
$html_header .= "</style>";
|
|
|
|
return (\$html_header);
|
|
|
|
} #-- End of subroutine create_html_header
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Create an HTML page with the warnings. If there are no warnings, include
|
|
# line to this extent. The alternative is to supporess the entire page, but
|
|
# that breaks the consistency in the output.
|
|
#------------------------------------------------------------------------------
|
|
sub create_html_warnings_page
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($outputdir_ref) = @_;
|
|
|
|
my $outputdir = ${ $outputdir_ref };
|
|
|
|
my $file_title;
|
|
my $html_acknowledgement;
|
|
my $html_end;
|
|
my $html_header;
|
|
my $html_home_left;
|
|
my $html_home_right;
|
|
my $html_title_header;
|
|
my $msg_no_warnings = "There are no warning messages issued.";
|
|
my $page_title;
|
|
my $position_text;
|
|
my $size_text;
|
|
|
|
my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html";
|
|
|
|
gp_message ("debug", $subr_name, "outfile = $outfile");
|
|
|
|
open (WARNINGS_OUT, ">", $outfile)
|
|
or die ("unable to open $outfile for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile for writing");
|
|
|
|
gp_message ("debug", $subr_name, "building warning file $outfile");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the number of warnings and in debug mode, print the list.
|
|
#------------------------------------------------------------------------------
|
|
my $number_of_warnings = scalar (@g_warning_messages);
|
|
gp_message ("debug", $subr_name, "number_of_warnings = $number_of_warnings");
|
|
|
|
if ($number_of_warnings > 0)
|
|
{
|
|
for my $i (0 .. $#g_warning_messages)
|
|
{
|
|
print "$g_warning_messages[$i]\n";
|
|
my $msg = "g_warning_messages[$i] = $g_warning_messages[$i]";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate some of the structures used in the HTML output.
|
|
#------------------------------------------------------------------------------
|
|
$file_title = "Warning messages";
|
|
$html_header = ${ create_html_header (\$file_title) };
|
|
$html_home_right = ${ generate_home_link ("right") };
|
|
|
|
$page_title = "Warning Messages";
|
|
$size_text = "h2";
|
|
$position_text = "center";
|
|
$html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Get the acknowledgement, return to main link, and final html statements.
|
|
#-------------------------------------------------------------------------------
|
|
$html_home_left = ${ generate_home_link ("left") };
|
|
$html_acknowledgement = ${ create_html_credits () };
|
|
$html_end = ${ terminate_html_document () };
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Generate the HTML file.
|
|
#-------------------------------------------------------------------------------
|
|
print WARNINGS_OUT $html_header;
|
|
print WARNINGS_OUT $html_home_right;
|
|
print WARNINGS_OUT $html_title_header;
|
|
|
|
if ($number_of_warnings > 0)
|
|
{
|
|
print WARNINGS_OUT "<pre>\n";
|
|
print WARNINGS_OUT "$_\n" for @g_warning_messages;
|
|
print WARNINGS_OUT "</pre>\n";
|
|
}
|
|
else
|
|
{
|
|
print WARNINGS_OUT $msg_no_warnings;
|
|
}
|
|
|
|
print WARNINGS_OUT $html_home_left;
|
|
print WARNINGS_OUT "<br>\n";
|
|
print WARNINGS_OUT $html_acknowledgement;
|
|
print WARNINGS_OUT $html_end;
|
|
|
|
close (WARNINGS_OUT);
|
|
|
|
return (\$number_of_warnings);
|
|
|
|
} #-- End of subroutine create_html_warnings_page
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Create a complete table.
|
|
#-------------------------------------------------------------------------------
|
|
sub create_table
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($experiment_data_ref, $table_definition_ref) = @_;
|
|
|
|
my @experiment_data = @{ $experiment_data_ref };
|
|
my @table_definition = @{ $table_definition_ref };
|
|
|
|
my @html_exp_table_data = ();
|
|
my $html_header_line;
|
|
my $html_table_line;
|
|
my $html_end_table;
|
|
|
|
$html_header_line = ${ create_table_header_exp (\@experiment_data) };
|
|
|
|
push (@html_exp_table_data, $html_header_line);
|
|
|
|
for my $i (sort keys @table_definition)
|
|
{
|
|
$html_table_line = ${ create_table_entry_exp (\$table_definition[$i]{"name"},
|
|
\$table_definition[$i]{"key"}, \@experiment_data) };
|
|
push (@html_exp_table_data, $html_table_line);
|
|
|
|
my $msg = "i = $i html_table_line = $html_table_line";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
|
|
$html_end_table = "</table>\n";
|
|
push (@html_exp_table_data, $html_end_table);
|
|
|
|
return (\@html_exp_table_data);
|
|
|
|
} #-- End of subroutine create_table
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Create one row for the table with experiment info.
|
|
#-------------------------------------------------------------------------------
|
|
sub create_table_entry_exp
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($entry_name_ref, $key_ref, $experiment_data_ref) = @_;
|
|
|
|
my $entry_name = ${ $entry_name_ref };
|
|
my $key = ${ $key_ref };
|
|
my @experiment_data = @{ $experiment_data_ref };
|
|
|
|
gp_message ("debugXL", $subr_name, "entry_name = $entry_name key = $key");
|
|
|
|
my $html_line;
|
|
|
|
$html_line = "<tr><div class=\"left\"><td><b> ";
|
|
$html_line = "<tr><div class=\"right\"><td><b> ";
|
|
$html_line .= $entry_name;
|
|
$html_line .= " </b></td>";
|
|
for my $i (sort keys @experiment_data)
|
|
{
|
|
if (exists ($experiment_data[$i]{$key}))
|
|
{
|
|
$html_line .= "<td> " . $experiment_data[$i]{$key} . " </td>";
|
|
}
|
|
else
|
|
{
|
|
## gp_message ("assertion", $subr_name, "experiment_data[$i]{$key} does not exist");
|
|
gp_message ("warning", $subr_name, "experiment_data[$i]{$key} does not exist");
|
|
}
|
|
}
|
|
$html_line .= "</div></tr>\n";
|
|
|
|
gp_message ("debugXL", $subr_name, "return html_line = $html_line");
|
|
|
|
return (\$html_line);
|
|
|
|
} #-- End of subroutine create_table_entry_exp
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Create the table header for the experiment info.
|
|
#-------------------------------------------------------------------------------
|
|
sub create_table_header_exp
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($experiment_data_ref) = @_;
|
|
|
|
my @experiment_data = @{ $experiment_data_ref };
|
|
my $html_header_line;
|
|
|
|
$html_header_line = "<style>\n";
|
|
$html_header_line .= "table, th, td {\n";
|
|
$html_header_line .= "border: 1px solid black;\n";
|
|
$html_header_line .= "border-collapse: collapse;\n";
|
|
$html_header_line .= "}\n";
|
|
$html_header_line .= "</style>\n";
|
|
$html_header_line .= "</pre>\n";
|
|
$html_header_line .= "<table>\n";
|
|
$html_header_line .= "<tr><div class=\"center\"><th></th>";
|
|
|
|
for my $i (sort keys @experiment_data)
|
|
{
|
|
$html_header_line .= "<th> Experiment ID " . $experiment_data[$i]{"exp_id"} . " </th>";
|
|
}
|
|
$html_header_line .= "</div></tr>\n";
|
|
|
|
gp_message ("debugXL", $subr_name, "html_header_line = $html_header_line");
|
|
|
|
return (\$html_header_line);
|
|
|
|
} #-- End of subroutine create_table_header_exp
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Handle where the output should go. If needed, a directory is created where
|
|
# the results will go.
|
|
#-------------------------------------------------------------------------------
|
|
sub define_the_output_directory
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($define_new_output_dir, $overwrite_output_dir) = @_;
|
|
|
|
my $outputdir;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# If neither -o or -O are set, find the next number to be used in the name for
|
|
# the default output directory.
|
|
#-------------------------------------------------------------------------------
|
|
if ((not $define_new_output_dir) and (not $overwrite_output_dir))
|
|
{
|
|
my $dir_id = 1;
|
|
while (-d "er.".$dir_id.".html")
|
|
{ $dir_id++; }
|
|
$outputdir = "er.".$dir_id.".html";
|
|
}
|
|
|
|
if (-d $outputdir)
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# The -o option is used, but the directory already exists.
|
|
#-------------------------------------------------------------------------------
|
|
if ($define_new_output_dir)
|
|
{
|
|
gp_message ("error", $subr_name, "directory $outputdir already exists");
|
|
gp_message ("abort", $subr_name, "use the -O option to overwrite an existing directory");
|
|
}
|
|
#-------------------------------------------------------------------------------
|
|
# This is a bit risky, so we proceed with caution. The output directory exists,
|
|
# but it is okay to overwrite it. It is removed here and created again below.
|
|
#-------------------------------------------------------------------------------
|
|
elsif ($overwrite_output_dir)
|
|
{
|
|
my $target_cmd = $g_mapped_cmds{"rm"};
|
|
my $rm_output = qx ($target_cmd -rf $outputdir);
|
|
my $error_code = ${^CHILD_ERROR_NATIVE};
|
|
if ($error_code != 0)
|
|
{
|
|
gp_message ("error", $subr_name, $rm_output);
|
|
gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "directory $outputdir has been removed");
|
|
}
|
|
}
|
|
}
|
|
#-------------------------------------------------------------------------------
|
|
# When we get here, the fatal scenarios have been cleared and the name for
|
|
# $outputdir is known. Time to create it.
|
|
#-------------------------------------------------------------------------------
|
|
if (mkdir ($outputdir, 0777))
|
|
{
|
|
gp_message ("debug", $subr_name, "created output directory $outputdir");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("abort", $subr_name, "a fatal problem occurred when creating directory $outputdir");
|
|
}
|
|
|
|
return ($outputdir);
|
|
|
|
} #-- End of subroutine define_the_output_directory
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Return the virtual address for the load object.
|
|
#
|
|
# Note that at this point, $elf_arch is known to be supported.
|
|
#
|
|
# TBD: Duplications?
|
|
#------------------------------------------------------------------------------
|
|
sub determine_base_va_address
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($executable_name, $base_va_executable, $loadobj, $routine) = @_;
|
|
|
|
my $name_loadobject;
|
|
my $base_va_address;
|
|
|
|
gp_message ("debugXL", $subr_name, "base_va_executable = $base_va_executable");
|
|
gp_message ("debugXL", $subr_name, "loadobj = $loadobj");
|
|
gp_message ("debugXL", $subr_name, "routine = $routine");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Strip the pathname from the load object name.
|
|
#------------------------------------------------------------------------------
|
|
$name_loadobject = get_basename ($loadobj);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If the load object is the executable, return the base address determined
|
|
# earlier. Otherwise return 0x0. Note that I am not sure if this is always
|
|
# the right thing to do, but for .so files it seems to work out fine.
|
|
#------------------------------------------------------------------------------
|
|
if ($name_loadobject eq $executable_name)
|
|
{
|
|
$base_va_address = $base_va_executable;
|
|
}
|
|
else
|
|
{
|
|
$base_va_address = "0x0";
|
|
}
|
|
|
|
my $decimal_address = bigint::hex ($base_va_address);
|
|
gp_message ("debugXL", $subr_name, "return base_va_address = $base_va_address (decimal: $decimal_address)");
|
|
|
|
return ($base_va_address);
|
|
|
|
} #-- End of subroutine determine_base_va_address
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Now that we know the map.xml file(s) are present, we can scan these and get
|
|
# the required information.
|
|
#-------------------------------------------------------------------------------
|
|
sub determine_base_virtual_address
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($exp_dir_list_ref) = @_;
|
|
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
|
|
my $full_path_exec;
|
|
my $executable_name;
|
|
my $va_executable_in_hex;
|
|
|
|
my $path_to_map_file;
|
|
|
|
for my $exp_dir (keys %g_exp_dir_meta_data)
|
|
{
|
|
$path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
|
|
$path_to_map_file .= $exp_dir;
|
|
$path_to_map_file .= "/map.xml";
|
|
|
|
($full_path_exec, $executable_name, $va_executable_in_hex) = extract_info_from_map_xml ($path_to_map_file);
|
|
|
|
$g_exp_dir_meta_data{$exp_dir}{"full_path_exec"} = $full_path_exec;
|
|
$g_exp_dir_meta_data{$exp_dir}{"exec_name"} = $executable_name;
|
|
$g_exp_dir_meta_data{$exp_dir}{"va_base_in_hex"} = $va_executable_in_hex;
|
|
|
|
gp_message ("debug", $subr_name, "exp_dir = $exp_dir");
|
|
gp_message ("debug", $subr_name, "full_path_exece = $full_path_exec");
|
|
gp_message ("debug", $subr_name, "executable_name = $executable_name");
|
|
gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
|
|
}
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine determine_base_virtual_address
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Determine whether the decimal separator is a point or a comma.
|
|
#------------------------------------------------------------------------------
|
|
sub determine_decimal_separator
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my $ignore_count;
|
|
my $decimal_separator;
|
|
my $convert_to_dot;
|
|
my $field;
|
|
my $target_found;
|
|
my $error_code;
|
|
my $cmd_output;
|
|
my $target_cmd;
|
|
my @locale_info;
|
|
|
|
my $default_decimal_separator = "\\.";
|
|
|
|
$target_cmd = $g_mapped_cmds{locale} . " -k LC_NUMERIC";
|
|
($error_code, $cmd_output) = execute_system_cmd ($target_cmd);
|
|
|
|
if ($error_code != 0)
|
|
#-------------------------------------------------------------------------------
|
|
# This is unlikely to happen, but you never know. To reduce the nesting level,
|
|
# return right here in case of an error.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("error", $subr_name, "failure to execute the command $target_cmd");
|
|
|
|
$convert_to_dot = $TRUE;
|
|
|
|
return ($error_code, $default_decimal_separator, $convert_to_dot);
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Scan the locale info and search for the target line of the form
|
|
# decimal_point="<target>" where <target> is either a dot, or a comma.
|
|
#-------------------------------------------------------------------------------
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Split the output into the different lines and scan for the line we need.
|
|
#-------------------------------------------------------------------------------
|
|
@locale_info = split ("\n", $cmd_output);
|
|
$target_found = $FALSE;
|
|
for my $line (@locale_info)
|
|
{
|
|
chomp ($line);
|
|
gp_message ("debug", $subr_name, "line from locale_info = $line");
|
|
if ($line =~ /decimal_point=/)
|
|
{
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Found the target line. Split this line to get the value field.
|
|
#-------------------------------------------------------------------------------
|
|
my @split_line = split ("=", $line);
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# There should be 2 fields. If not, something went wrong.
|
|
#-------------------------------------------------------------------------------
|
|
if (scalar @split_line != 2)
|
|
{
|
|
# if (scalar @split_line == 2) {
|
|
# $target_found = $FALSE;
|
|
#-------------------------------------------------------------------------------
|
|
# Remove the newline before printing the variables.
|
|
#-------------------------------------------------------------------------------
|
|
$ignore_count = chomp ($line);
|
|
$ignore_count = chomp (@split_line);
|
|
gp_message ("debug", $subr_name, "warning - line $line matches the search, but the decimal separator has the wrong format");
|
|
gp_message ("debug", $subr_name, "warning - the splitted line is [@split_line] and does not contain 2 fields");
|
|
gp_message ("debug", $subr_name, "warning - the default decimal separator will be used");
|
|
}
|
|
else
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# We know there are 2 fields and the second one has the decimal point.
|
|
#-------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "split_line[1] = $split_line[1]");
|
|
|
|
chomp ($split_line[1]);
|
|
$field = $split_line[1];
|
|
|
|
if (length ($field) != 3)
|
|
#-------------------------------------------------------------------------------
|
|
# The field still includes the quotes. Check if the string has length 3, which
|
|
# should be the case, but if not, we flag an error. The error code is set such
|
|
# that the callee will know a problem has occurred.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("error", $subr_name, "unexpected output from the $target_cmd command: $field");
|
|
$error_code = 1;
|
|
last;
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "field = ->$field<-");
|
|
|
|
if (($field eq "\".\"") or ($field eq "\",\""))
|
|
#-------------------------------------------------------------------------------
|
|
# Found the separator. Capture the character between the quotes.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
$target_found = $TRUE;
|
|
$decimal_separator = substr ($field,1,1);
|
|
gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator--end skip loop");
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if (not $target_found)
|
|
{
|
|
$decimal_separator = $default_decimal_separator;
|
|
gp_message ("warning", $subr_name, "cannot determine the decimal separator - use the default $decimal_separator");
|
|
}
|
|
|
|
if ($decimal_separator ne ".")
|
|
{
|
|
$convert_to_dot = $TRUE;
|
|
}
|
|
else
|
|
{
|
|
$convert_to_dot = $FALSE;
|
|
}
|
|
|
|
$decimal_separator = "\\".$decimal_separator;
|
|
$g_locale_settings{"decimal_separator"} = $decimal_separator;
|
|
$g_locale_settings{"convert_to_dot"} = $convert_to_dot;
|
|
|
|
return ($error_code, $decimal_separator, $convert_to_dot);
|
|
|
|
} #-- End of subroutine determine_decimal_separator
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub dump_function_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($function_info_ref, $name) = @_;
|
|
|
|
my %function_info = %{$function_info_ref};
|
|
my $kip;
|
|
|
|
gp_message ("debug", $subr_name, "function_info for $name");
|
|
$kip = 0;
|
|
for my $farray ($function_info{$name})
|
|
{
|
|
for my $elm (@{$farray})
|
|
{
|
|
gp_message ("debug", $subr_name, "$kip: routine = ${$elm}{'routine'}");
|
|
for my $key (sort keys %{$elm})
|
|
{
|
|
if ($key eq "routine")
|
|
{
|
|
next;
|
|
}
|
|
gp_message ("debug", $subr_name, "$kip: $key = ${$elm}{$key}");
|
|
}
|
|
$kip++;
|
|
}
|
|
}
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine dump_function_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is an early scan to find the settings for some options very early on.
|
|
# For practical reasons the main option parsing and handling is done later,
|
|
# but without this early scan, these options will not be enabled until later
|
|
# in the execution.
|
|
#
|
|
# This early scan fixes that, but it is not very elegant to do it this way
|
|
# and in the future, this will be improved. For now it gets the job done.
|
|
#------------------------------------------------------------------------------
|
|
sub early_scan_specific_options
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my @options_with_value = qw /verbose warnings debug quiet/;
|
|
my $target_option;
|
|
|
|
my $ignore_value;
|
|
my $found_option;
|
|
my $option_requires_value;
|
|
my $option_value;
|
|
my $valid_input;
|
|
my @error_messages = ();
|
|
|
|
$option_requires_value = $TRUE;
|
|
for (@options_with_value)
|
|
{
|
|
$target_option = $_;
|
|
($found_option, $option_value) = find_target_option (
|
|
\@ARGV,
|
|
$option_requires_value,
|
|
$target_option);
|
|
if ($found_option)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# This part has been set up such that we can support other options too, should
|
|
# this become necessary.
|
|
#
|
|
# A necessary, but limited check for the validity of a value is performed.
|
|
# This avoids that an error message shows up twice later on.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# All option values are converted to lower case. This makes the checks easier.
|
|
#------------------------------------------------------------------------------
|
|
|
|
if ($target_option eq "verbose")
|
|
{
|
|
my $verbose_value = lc ($option_value);
|
|
$valid_input = verify_if_input_is_valid ($verbose_value, "onoff");
|
|
if ($valid_input)
|
|
{
|
|
$g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE;
|
|
if ($verbose_value eq "on")
|
|
#------------------------------------------------------------------------------
|
|
# Set the status and disable output buffering in verbose mode.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$g_user_settings{"verbose"}{"current_value"} = "on";
|
|
STDOUT->autoflush (1);
|
|
}
|
|
elsif ($verbose_value eq "off")
|
|
{
|
|
$g_user_settings{"verbose"}{"current_value"} = "off";
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "$option_value is not supported for the verbose option";
|
|
push (@error_messages, $msg);
|
|
}
|
|
}
|
|
elsif ($target_option eq "warnings")
|
|
{
|
|
my $warnings_value = lc ($option_value);
|
|
$valid_input = verify_if_input_is_valid ($warnings_value, "onoff");
|
|
if ($valid_input)
|
|
{
|
|
$g_warnings = ($warnings_value eq "on") ? $TRUE : $FALSE;
|
|
if ($warnings_value eq "on")
|
|
#------------------------------------------------------------------------------
|
|
# Set the status and disable output buffering if warnings are enabled.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$g_user_settings{"warnings"}{"current_value"} = "on";
|
|
STDOUT->autoflush (1);
|
|
}
|
|
elsif ($warnings_value eq "off")
|
|
{
|
|
$g_user_settings{"warnings"}{"current_value"} = "off";
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "$option_value is not supported for the warnings option";
|
|
push (@error_messages, $msg);
|
|
}
|
|
}
|
|
elsif ($target_option eq "quiet")
|
|
{
|
|
my $quiet_value = lc ($option_value);
|
|
$valid_input = verify_if_input_is_valid ($option_value, "onoff");
|
|
if ($valid_input)
|
|
{
|
|
$g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE;
|
|
if ($quiet_value eq "on")
|
|
{
|
|
$g_user_settings{"quiet"}{"current_value"} = "on";
|
|
}
|
|
elsif ($quiet_value eq "off")
|
|
{
|
|
$g_user_settings{"quiet"}{"current_value"} = "off";
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "$option_value is not supported for the quiet option";
|
|
push (@error_messages, $msg);
|
|
}
|
|
}
|
|
elsif ($target_option eq "debug")
|
|
{
|
|
my $debug_value = lc ($option_value);
|
|
$valid_input = verify_if_input_is_valid ($debug_value, "size");
|
|
if ($valid_input)
|
|
{
|
|
if ($debug_value ne "off")
|
|
#------------------------------------------------------------------------------
|
|
# Disable output buffering in debug mode.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$g_user_settings{"debug"}{"current_value"} = "on";
|
|
STDOUT->autoflush (1);
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# This function also sets $g_user_settings{"debug"}{"current_value"}.
|
|
#------------------------------------------------------------------------------
|
|
my $ignore_value = set_debug_size (\$debug_value);
|
|
}
|
|
else
|
|
{
|
|
my $msg = "$option_value is not supported for the debug option";
|
|
push (@error_messages, $msg);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "target option $target_option not expected";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check for input errors.
|
|
#------------------------------------------------------------------------------
|
|
my $input_errors = scalar (@error_messages);
|
|
if ($input_errors > 0)
|
|
{
|
|
my $plural = ($input_errors == 1) ?
|
|
"is one error" : "are $input_errors errors";
|
|
print "There " . $plural . " in the options:\n";
|
|
for my $i (0 .. $#error_messages)
|
|
{
|
|
print "- $error_messages[$i]\n";
|
|
}
|
|
exit (0);
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# If quiet mode has been enabled, disable verbose, warnings and debug.
|
|
#------------------------------------------------------------------------------
|
|
if ($g_quiet)
|
|
{
|
|
$g_user_settings{"verbose"}{"current_value"} = "off";
|
|
$g_user_settings{"warnings"}{"current_value"} = "off";
|
|
$g_user_settings{"debug"}{"current_value"} = "off";
|
|
$g_verbose = $FALSE;
|
|
$g_warnings = $FALSE;
|
|
my $debug_off = "off";
|
|
my $ignore_value = set_debug_size (\$debug_off);
|
|
}
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine early_scan_specific_options
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub elf_phdr
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine,
|
|
$ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_;
|
|
|
|
my %elf_rats = %{$elf_rats_ref};
|
|
|
|
my $return_value;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD. Quick check. Can be moved up the call tree.
|
|
#------------------------------------------------------------------------------
|
|
if ( ($elf_arch ne "Linux") and ($elf_arch ne "SunOS") )
|
|
{
|
|
gp_message ("abort", $subr_name, "$elf_arch is not a supported OS");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: This should not be in a loop over $loadobj and only use the executable.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: $routine is not really used in these subroutines. Is this a bug?
|
|
#------------------------------------------------------------------------------
|
|
if ($elf_loadobjects_found)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "calling elf_phdr_usual");
|
|
$return_value = elf_phdr_usual ($elf_arch, $loadobj, $routine, \%elf_rats);
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debugXL", $subr_name, "calling elf_phdr_sometimes");
|
|
$return_value = elf_phdr_sometimes ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR);
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "the return value = $return_value");
|
|
|
|
if (not $return_value)
|
|
{
|
|
gp_message ("abort", $subr_name, "need to handle a return value of FALSE");
|
|
}
|
|
return ($return_value);
|
|
|
|
} #-- End of subroutine elf_phdr
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Return the virtual address for the load object.
|
|
#------------------------------------------------------------------------------
|
|
sub elf_phdr_sometimes
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME,
|
|
$ARCHIVES_MAP_VADDR) = @_;
|
|
|
|
my $arch_uname_s = $local_system_config{"kernel_name"};
|
|
my $arch_uname = $local_system_config{"processor"};
|
|
my $arch = $g_arch_specific_settings{"arch"};
|
|
|
|
gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s");
|
|
gp_message ("debug", $subr_name, "arch_uname = $arch_uname");
|
|
gp_message ("debug", $subr_name, "arch = $arch");
|
|
|
|
my $target_cmd;
|
|
my $command_string;
|
|
my $error_code;
|
|
my $cmd_output;
|
|
|
|
my $line;
|
|
my $blo;
|
|
|
|
my $elf_offset;
|
|
my $i;
|
|
my @foo;
|
|
my $foo;
|
|
my $foo1;
|
|
my $p_vaddr;
|
|
my $rc;
|
|
my $archives_file;
|
|
my $loadobj_SAVE;
|
|
my $Offset;
|
|
my $VirtAddr;
|
|
my $PhysAddr;
|
|
my $FileSiz;
|
|
my $MemSiz;
|
|
my $Flg;
|
|
my $Align;
|
|
|
|
if ($ARCHIVES_MAP_NAME eq $blo)
|
|
{
|
|
return ($ARCHIVES_MAP_VADDR);
|
|
}
|
|
else
|
|
{
|
|
return ($FALSE);
|
|
}
|
|
|
|
if ($arch_uname_s ne $elf_arch)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# We are masquerading between systems, must leave
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch");
|
|
return ($FALSE);
|
|
}
|
|
if ($loadobj eq "DYNAMIC_FUNCTIONS")
|
|
#------------------------------------------------------------------------------
|
|
# Linux vDSO, leave for now
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
return ($FALSE);
|
|
}
|
|
|
|
# TBD: STILL NEEDED??!!
|
|
|
|
$loadobj_SAVE = $loadobj;
|
|
|
|
$blo = get_basename ($loadobj);
|
|
gp_message ("debug", $subr_name, "loadobj = $loadobj");
|
|
gp_message ("debug", $subr_name, "blo = $blo");
|
|
gp_message ("debug", $subr_name, "ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
|
|
gp_message ("debug", $subr_name, "ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
|
|
if ($ARCHIVES_MAP_NAME eq $blo)
|
|
{
|
|
return ($ARCHIVES_MAP_VADDR);
|
|
}
|
|
else
|
|
{
|
|
return ($FALSE);
|
|
}
|
|
|
|
} #-- End of subroutine elf_phdr_sometimes
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Return the virtual address for the load object.
|
|
#
|
|
# Note that at this point, $elf_arch is known to be supported.
|
|
#------------------------------------------------------------------------------
|
|
sub elf_phdr_usual
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($elf_arch, $loadobj, $routine, $elf_rats_ref) = @_;
|
|
|
|
my %elf_rats = %{$elf_rats_ref};
|
|
|
|
my $return_code;
|
|
my $cmd_output;
|
|
my $target_cmd;
|
|
my $command_string;
|
|
my $error_code;
|
|
my $error_code1;
|
|
my $error_code2;
|
|
|
|
my ($elf_offset, $loadobjARC);
|
|
my ($i, @foo, $foo, $foo1, $p_vaddr, $rc);
|
|
my ($Offset, $VirtAddr, $PhysAddr, $FileSiz, $MemSiz, $Flg, $Align);
|
|
|
|
my $arch_uname_s = $local_system_config{"kernel_name"};
|
|
|
|
gp_message ("debug", $subr_name, "elf_arch = $elf_arch loadobj = $loadobj routine = $routine");
|
|
|
|
my ($base, $ignore_value, $ignore_too) = fileparse ($loadobj);
|
|
gp_message ("debug", $subr_name, "base = $base ".basename ($loadobj));
|
|
|
|
if ($elf_arch eq "Linux")
|
|
{
|
|
if ($arch_uname_s ne $elf_arch)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# We are masquerading between systems, must leave.
|
|
# Maybe we could use ELF_RATS
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch");
|
|
return ($FALSE);
|
|
}
|
|
if ($loadobj eq "DYNAMIC_FUNCTIONS")
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Linux vDSO, leave for now
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "early return: loadobj = $loadobj");
|
|
return ($FALSE);
|
|
}
|
|
|
|
$target_cmd = $g_mapped_cmds{"readelf"};
|
|
$command_string = $target_cmd . " -l " . $loadobj . " 2>/dev/null";
|
|
|
|
($error_code1, $cmd_output) = execute_system_cmd ($command_string);
|
|
|
|
gp_message ("debug", $subr_name, "executed command_string = $command_string");
|
|
gp_message ("debug", $subr_name, "cmd_output = $cmd_output");
|
|
|
|
if ($error_code1 != 0)
|
|
{
|
|
gp_message ("debug", $subr_name, "call failure for $command_string");
|
|
#------------------------------------------------------------------------------
|
|
# e.g. $loadobj->/usr/lib64/libc-2.17.so
|
|
#------------------------------------------------------------------------------
|
|
$loadobjARC = get_basename ($loadobj);
|
|
gp_message ("debug", $subr_name, "seek elf_rats for $loadobjARC");
|
|
|
|
if (exists ($elf_rats{$loadobjARC}))
|
|
{
|
|
my $elfoid = "$elf_rats{$loadobjARC}[1]/archives/$elf_rats{$loadobjARC}[0]";
|
|
$target_cmd = $g_mapped_cmds{"readelf"};
|
|
$command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null";
|
|
($error_code2, $cmd_output) = execute_system_cmd ($command_string);
|
|
|
|
if ($error_code2 != 0)
|
|
{
|
|
gp_message ("abort", $subr_name, "call failure for $command_string");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "executed command_string = $command_string");
|
|
gp_message ("debug", $subr_name, "cmd_output = $cmd_output");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "elf_rats{$loadobjARC} does not exist";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Example output of "readelf -l" on Linux:
|
|
#
|
|
# Elf file type is EXEC (Executable file)
|
|
# Entry point 0x4023a0
|
|
# There are 11 program headers, starting at offset 64
|
|
#
|
|
# Program Headers:
|
|
# Type Offset VirtAddr PhysAddr
|
|
# FileSiz MemSiz Flags Align
|
|
# PHDR 0x0000000000000040 0x0000000000400040 0x0000000000400040
|
|
# 0x0000000000000268 0x0000000000000268 R 8
|
|
# INTERP 0x00000000000002a8 0x00000000004002a8 0x00000000004002a8
|
|
# 0x000000000000001c 0x000000000000001c R 1
|
|
# [Requesting program interpreter: /lib64/ld-linux-x86-64.so.2]
|
|
# LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000
|
|
# 0x0000000000001310 0x0000000000001310 R 1000
|
|
# LOAD 0x0000000000002000 0x0000000000402000 0x0000000000402000
|
|
# 0x0000000000006515 0x0000000000006515 R E 1000
|
|
# LOAD 0x0000000000009000 0x0000000000409000 0x0000000000409000
|
|
# 0x000000000006f5a8 0x000000000006f5a8 R 1000
|
|
# LOAD 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8
|
|
# 0x000000000000047c 0x0000000000000f80 RW 1000
|
|
# DYNAMIC 0x0000000000078dd8 0x0000000000479dd8 0x0000000000479dd8
|
|
# 0x0000000000000220 0x0000000000000220 RW 8
|
|
# NOTE 0x00000000000002c4 0x00000000004002c4 0x00000000004002c4
|
|
# 0x0000000000000044 0x0000000000000044 R 4
|
|
# GNU_EH_FRAME 0x00000000000777f4 0x00000000004777f4 0x00000000004777f4
|
|
# 0x000000000000020c 0x000000000000020c R 4
|
|
# GNU_STACK 0x0000000000000000 0x0000000000000000 0x0000000000000000
|
|
# 0x0000000000000000 0x0000000000000000 RW 10
|
|
# GNU_RELRO 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8
|
|
# 0x0000000000000238 0x0000000000000238 R 1
|
|
#
|
|
# Section to Segment mapping:
|
|
# Segment Sections...
|
|
# 00
|
|
# 01 .interp
|
|
# 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt
|
|
# 03 .init .plt .text .fini
|
|
# 04 .rodata .eh_frame_hdr .eh_frame
|
|
# 05 .init_array .fini_array .dynamic .got .got.plt .data .bss
|
|
# 06 .dynamic
|
|
# 07 .note.gnu.build-id .note.ABI-tag
|
|
# 08 .eh_frame_hdr
|
|
# 09
|
|
# 10 .init_array .fini_array .dynamic .got
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Analyze the ELF information and try to find the virtual address.
|
|
#
|
|
# Note that the information printed as part of LOAD needs to have "R E" in it.
|
|
# In the example output above, the return value would be "0x0000000000402000".
|
|
#
|
|
# We also need to distinguish two cases. It could be that the output is on
|
|
# a single line, or spread over two lines:
|
|
#
|
|
# Offset VirtAddr PhysAddr FileSiz MemSiz Flg Align
|
|
# LOAD 0x000000 0x08048000 0x08048000 0x61b4ae 0x61b4ae R E 0x1000
|
|
# or 2 lines
|
|
# LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000
|
|
# 0x0000000000001010 0x0000000000001010 R E 200000
|
|
#------------------------------------------------------------------------------
|
|
@foo = split ("\n",$cmd_output);
|
|
for $i (0 .. $#foo)
|
|
{
|
|
$foo = $foo[$i];
|
|
chomp ($foo);
|
|
if ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/)
|
|
{
|
|
$Offset = $1;
|
|
$VirtAddr = $2;
|
|
$PhysAddr = $3;
|
|
$FileSiz = $4;
|
|
$MemSiz = $5;
|
|
$Flg = $6;
|
|
$Align = $7;
|
|
|
|
$elf_offset = $VirtAddr;
|
|
gp_message ("debug", $subr_name, "single line version elf_offset = $elf_offset");
|
|
return ($elf_offset);
|
|
}
|
|
elsif ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$/)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# is it a two line version?
|
|
#------------------------------------------------------------------------------
|
|
$Offset = $1;
|
|
$VirtAddr = $2; # maybe
|
|
$PhysAddr = $3;
|
|
if ($i != $#foo)
|
|
{
|
|
$foo1 = $foo[$i + 1];
|
|
chomp ($foo1);
|
|
if ($foo1 =~ /^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/)
|
|
{
|
|
$FileSiz = $1;
|
|
$MemSiz = $2;
|
|
$Flg = $3;
|
|
$Align = $4;
|
|
$elf_offset = $VirtAddr;
|
|
gp_message ("debug", $subr_name, "two line version elf_offset = $elf_offset");
|
|
return ($elf_offset);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
elsif ($elf_arch eq "SunOS")
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
#Program Header[3]:
|
|
# p_vaddr: 0x10000 p_flags: [ PF_X PF_R ]
|
|
# folowed by
|
|
# p_paddr: 0 p_type: [ PT_LOAD ]
|
|
#------------------------------------------------------------------------------
|
|
if ($arch_uname_s ne $elf_arch)
|
|
#------------------------------------------------------------------------------
|
|
# we are masquerading between systems, must leave
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("debug", $subr_name,"masquerading arch_uname_s = $arch_uname_s elf_arch = $elf_arch");
|
|
return (0);
|
|
}
|
|
$target_cmd = $g_mapped_cmds{"elfdump"};
|
|
$command_string = $target_cmd . "-p " . $loadobj . " 2>/dev/null";
|
|
($error_code, $cmd_output) = execute_system_cmd ($command_string);
|
|
if ($error_code != 0)
|
|
{
|
|
gp_message ("debug", $subr_name,"call failure for $command_string");
|
|
die ("$target_cmd call failure");
|
|
}
|
|
my @foo = split ("\n",$cmd_output);
|
|
for $i (0 .. $#foo)
|
|
{
|
|
$foo = $foo[$i];
|
|
chomp ($foo);
|
|
if ($foo =~ /^\s+p_vaddr:\s+(\S+)\s+p_flags:\s+\[\sPF_X\sPF_R\s\]$/)
|
|
{
|
|
$p_vaddr = $1; # probably
|
|
if ($i != $#foo)
|
|
{
|
|
$foo1 = $foo[$i + 1];
|
|
chomp ($foo1);
|
|
if ($foo1 =~ /^\s+p_paddr:\s+(\S+)\s+p_type:\s+\[\sPT_LOAD\s\]$/)
|
|
{
|
|
$elf_offset = $p_vaddr;
|
|
return ($elf_offset);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
} #-- End of subroutine elf_phdr_usual
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Execute a system command. In case of an error, a non-zero error code is
|
|
# returned. It is upon the caller to decide what to do next.
|
|
#------------------------------------------------------------------------------
|
|
sub execute_system_cmd
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($target_cmd) = @_;
|
|
|
|
chomp ($target_cmd);
|
|
|
|
my $cmd_output = qx ($target_cmd);
|
|
my $error_code = ${^CHILD_ERROR_NATIVE};
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
gp_message ("error", $subr_name, "failure executing command $target_cmd");
|
|
gp_message ("error", $subr_name, "error code = $error_code");
|
|
}
|
|
else
|
|
{
|
|
chomp ($cmd_output);
|
|
gp_message ("debugM", $subr_name, "executed command $target_cmd");
|
|
gp_message ("debugM", $subr_name, "cmd_output = $cmd_output");
|
|
}
|
|
|
|
return ($error_code, $cmd_output);
|
|
|
|
} #-- End of subroutine execute_system_cmd
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Scan the input file, which should be a gprofng generated map.xml file, and
|
|
# extract the relevant information.
|
|
#------------------------------------------------------------------------------
|
|
sub extract_info_from_map_xml
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_map_xml_file) = @_;
|
|
|
|
my $extracted_information;
|
|
my $input_line;
|
|
my $vaddr;
|
|
my $foffset;
|
|
my $modes;
|
|
my $name_path;
|
|
my $name;
|
|
|
|
my $full_path_exec;
|
|
my $executable_name;
|
|
my $va_executable_in_hex;
|
|
|
|
open (MAP_XML, "<", $input_map_xml_file)
|
|
or die ("$subr_name - unable to open file $input_map_xml_file for reading: $!");
|
|
gp_message ("debug", $subr_name, "opened file $input_map_xml_file for reading");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Scan the file. We need to find the name of the executable with the mode set
|
|
# to 0x005. For this entry we have to capture the name, the mode, the virtual
|
|
# address and the offset.
|
|
#------------------------------------------------------------------------------
|
|
$extracted_information = $FALSE;
|
|
while (<MAP_XML>)
|
|
{
|
|
$input_line = $_;
|
|
chomp ($input_line);
|
|
gp_message ("debug", $subr_name, "read input_line = $input_line");
|
|
if ($input_line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.*foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*name="(.*)".*>$/)
|
|
{
|
|
gp_message ("debug", $subr_name, "target line = $input_line");
|
|
|
|
$vaddr = $1;
|
|
$foffset = $2;
|
|
$modes = $3;
|
|
$name_path = $4;
|
|
$name = get_basename ($name_path);
|
|
gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes");
|
|
gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The base virtual address is calculated as vaddr-foffset. Although Perl
|
|
# handles arithmetic in hex, we take the safe way here. Maybe overkill, but
|
|
# I prefer to be safe than sorry in cases like this.
|
|
#------------------------------------------------------------------------------
|
|
$full_path_exec = $name_path;
|
|
$executable_name = $name;
|
|
my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset);
|
|
$va_executable_in_hex = sprintf ("0x%016x", $result_VA);
|
|
|
|
## $ARCHIVES_MAP_NAME = $name;
|
|
## $ARCHIVES_MAP_VADDR = $va_executable_in_hex;
|
|
|
|
## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
|
|
## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
|
|
gp_message ("debug", $subr_name, "result_VA = $result_VA");
|
|
gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Stop reading when we found the correct entry.
|
|
#------------------------------------------------------------------------------
|
|
if ($modes eq "005")
|
|
{
|
|
$extracted_information = $TRUE;
|
|
last;
|
|
}
|
|
}
|
|
} #-- End of while-loop
|
|
|
|
if (not $extracted_information)
|
|
{
|
|
my $msg = "cannot find the necessary information in file $input_map_xml_file";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "full_path_exec = $full_path_exec");
|
|
gp_message ("debug", $subr_name, "executable_name = $executable_name");
|
|
gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex");
|
|
|
|
return ($full_path_exec, $executable_name, $va_executable_in_hex);
|
|
|
|
} #-- End of subroutine extract_info_from_map_xml
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This routine analyzes the metric line and extracts the metric specifics
|
|
# from it.
|
|
# Example input: Exclusive Total CPU Time: e.%totalcpu
|
|
#------------------------------------------------------------------------------
|
|
sub extract_metric_specifics
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($metric_line) = @_;
|
|
|
|
my $metric_description;
|
|
my $metric_flavor;
|
|
my $metric_visibility;
|
|
my $metric_name;
|
|
my $metric_spec;
|
|
|
|
# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){
|
|
if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/))
|
|
{
|
|
gp_message ("debug", $subr_name, "line of interest: $metric_line");
|
|
|
|
$metric_description = $1;
|
|
$metric_flavor = $2;
|
|
$metric_visibility = $3;
|
|
$metric_name = $4;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Although we have captured the metric visibility, the original code removes
|
|
# this from the name. Since the structure is more complicated, the code is
|
|
# more tedious as well. With our new approach we just leave the visibility
|
|
# out.
|
|
#------------------------------------------------------------------------------
|
|
# $metric_spec = $metric_flavor.$metric_visibility.$metric_name;
|
|
|
|
$metric_spec = $metric_flavor . "." . $metric_name;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# From the original code:
|
|
#
|
|
# On x64 systems there are metrics which contain ~ (for example
|
|
# DC_access~umask=0 . When er_print lists them, they come out
|
|
# as DC_access%7e%umask=0 (see 6530691). Untill 6530691 is
|
|
# fixed, we need this. Later we may need something else, or
|
|
# things may just work.
|
|
#------------------------------------------------------------------------------
|
|
# $metric_spec=~s/\%7e\%/,/;
|
|
# # remove % metric
|
|
# print "DB: before \$metric_spec = $metric_spec\n";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: I don't know why the "%" symbol is removed.
|
|
#------------------------------------------------------------------------------
|
|
# $metric_spec =~ s/\%//;
|
|
# print "DB: after \$metric_spec = $metric_spec\n";
|
|
|
|
return ($metric_spec, $metric_flavor, $metric_visibility,
|
|
$metric_name, $metric_description);
|
|
}
|
|
else
|
|
{
|
|
return ("skipped", "void");
|
|
}
|
|
|
|
} #-- End of subroutine extract_metric_specifics
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub extract_source_line_number
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($src_times_regex, $function_regex, $number_of_metrics, $input_line) = @_;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The regex section.
|
|
#------------------------------------------------------------------------------
|
|
my $find_dot_regex = '\.';
|
|
|
|
my @fields_in_line = ();
|
|
my $hot_line;
|
|
my $line_id;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# To extract the source line number, we need to distinguish whether this is
|
|
# a line with, or without metrics.
|
|
#------------------------------------------------------------------------------
|
|
@fields_in_line = split (" ", $input_line);
|
|
if ( $input_line =~ /$src_times_regex/ )
|
|
{
|
|
$hot_line = $1;
|
|
if ($hot_line eq "##")
|
|
#------------------------------------------------------------------------------
|
|
# The line id comes after the "##" symbol and the metrics.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$line_id = $fields_in_line[$number_of_metrics+1];
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# The line id comes after the metrics.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$line_id = $fields_in_line[$number_of_metrics];
|
|
}
|
|
}
|
|
elsif ($input_line =~ /$function_regex/)
|
|
{
|
|
$line_id = "func";
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# The line id is the first non-blank element.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$line_id = $fields_in_line[0];
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Remove the trailing dot.
|
|
#------------------------------------------------------------------------------
|
|
$line_id =~ s/$find_dot_regex//;
|
|
|
|
return ($line_id);
|
|
|
|
} #-- End of subroutine extract_source_line_number
|
|
|
|
#------------------------------------------------------------------------------
|
|
# For a give routine name and address, find the index into the
|
|
# function_info array
|
|
#------------------------------------------------------------------------------
|
|
sub find_index_in_function_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($routine_ref, $current_address_ref, $function_info_ref) = @_;
|
|
|
|
my $routine = ${ $routine_ref };
|
|
my $current_address = ${ $current_address_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
|
|
my $addr_offset;
|
|
my $ref_index;
|
|
|
|
gp_message ("debugXL", $subr_name, "find index for routine = $routine and current_address = $current_address");
|
|
if (exists ($g_multi_count_function{$routine}))
|
|
{
|
|
|
|
# TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!!
|
|
|
|
gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
|
|
for my $ref (keys @{ $g_map_function_to_index{$routine} })
|
|
{
|
|
$ref_index = $g_map_function_to_index{$routine}[$ref];
|
|
|
|
gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
|
|
gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
|
|
|
|
$addr_offset = $function_info[$ref_index]{"addressobjtext"};
|
|
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
|
|
|
|
$addr_offset =~ s/^@\d+://;
|
|
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
|
|
if ($addr_offset eq $current_address)
|
|
{
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# There is only a single occurrence and it is straightforward to get the index.
|
|
#------------------------------------------------------------------------------
|
|
if (exists ($g_map_function_to_index{$routine}))
|
|
{
|
|
$ref_index = $g_map_function_to_index{$routine}[0];
|
|
}
|
|
else
|
|
{
|
|
my $msg = "index for $routine cannot be determined";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address ref_index = $ref_index");
|
|
|
|
return (\$ref_index);
|
|
|
|
} #-- End of subroutine find_index_in_function_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub find_keyword_in_string
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($target_string_ref, $target_keyword_ref) = @_;
|
|
|
|
my $target_string = ${ $target_string_ref };
|
|
my $target_keyword = ${ $target_keyword_ref };
|
|
my $foundit = $FALSE;
|
|
|
|
my @index_values = ();
|
|
|
|
my $ret_val = 0;
|
|
my $offset = 0;
|
|
gp_message ("debugXL", $subr_name, "target_string = $target_string");
|
|
$ret_val = index ($target_string, $target_keyword, $offset);
|
|
gp_message ("debugXL", $subr_name, "ret_val = $ret_val");
|
|
|
|
if ($ret_val != -1)
|
|
{
|
|
$foundit = $TRUE;
|
|
while ($ret_val != -1)
|
|
{
|
|
push (@index_values, $ret_val);
|
|
$offset = $ret_val + 1;
|
|
gp_message ("debugXL", $subr_name, "ret_val = $ret_val offset = $offset");
|
|
$ret_val = index ($target_string, $target_keyword, $offset);
|
|
}
|
|
for my $i (keys @index_values)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "index_values[$i] = $index_values[$i]");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debugXL", $subr_name, "target keyword $target_keyword not found");
|
|
}
|
|
|
|
return (\$foundit, \@index_values);
|
|
|
|
} #-- End of subroutine find_keyword_in_string
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Retrieve the absolute path that was used to execute the command. This path
|
|
# is used to execute gp-display-text later on.
|
|
#------------------------------------------------------------------------------
|
|
sub find_path_to_gp_display_text
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($full_command_ref) = @_;
|
|
|
|
my $full_command = ${ $full_command_ref };
|
|
|
|
my $error_occurred = $TRUE;
|
|
my $return_value;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the path name.
|
|
#------------------------------------------------------------------------------
|
|
my ($gp_file_name, $gp_path, $suffix_not_used) = fileparse ($full_command);
|
|
|
|
gp_message ("debug", $subr_name, "full_command = $full_command");
|
|
gp_message ("debug", $subr_name, "gp_path = $gp_path");
|
|
|
|
my $gp_display_text_instance = $gp_path . $GP_DISPLAY_TEXT;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if $GP_DISPLAY_TEXT exists, is not empty, and executable.
|
|
#------------------------------------------------------------------------------
|
|
if (not -e $gp_display_text_instance)
|
|
{
|
|
$return_value = "file not found";
|
|
}
|
|
else
|
|
{
|
|
if (is_file_empty ($gp_display_text_instance))
|
|
{
|
|
$return_value = "file is empty";
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# All is well. Capture the path.
|
|
#------------------------------------------------------------------------------
|
|
$error_occurred = $FALSE;
|
|
$return_value = $gp_path;
|
|
}
|
|
}
|
|
|
|
return (\$error_occurred, \$return_value);
|
|
|
|
} #-- End of subroutine find_path_to_gp_display_text
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Scan the command line to see if the specified option is present.
|
|
#
|
|
# Two types of options are supported: options without a value (e.g. --help) or
|
|
# those that are set to "on" or "off".
|
|
#
|
|
# In this phase, we only need to check if a value is valid. If it is, we have
|
|
# to enable the corresponding global setting. If the value is not valid, we
|
|
# ignore it, since it will be caught later and a warning message is issued.
|
|
#------------------------------------------------------------------------------
|
|
sub find_target_option
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($command_line_ref, $option_requires_value, $target_option) = @_;
|
|
|
|
my @command_line = @{ $command_line_ref };
|
|
my $option_value = undef;
|
|
my $found_option = $FALSE;
|
|
|
|
my ($command_line_string) = join (" ", @command_line);
|
|
|
|
## if ($command_line_string =~ /\s*($target_option)\s*(on|off)*\s*/)
|
|
#------------------------------------------------------------------------------
|
|
# This does not make any assumptions on the values we are looking for.
|
|
#------------------------------------------------------------------------------
|
|
if ($command_line_string =~ /\s*\-\-($target_option)\s*(\w*)\s*/)
|
|
{
|
|
if (defined ($1))
|
|
#------------------------------------------------------------------------------
|
|
# We have found the option we are looking for.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$found_option = $TRUE;
|
|
if ($option_requires_value and defined ($2))
|
|
#------------------------------------------------------------------------------
|
|
# There is a value and it is passed on to the caller.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$option_value = $2;
|
|
}
|
|
}
|
|
}
|
|
|
|
return ($found_option, $option_value);
|
|
|
|
} #-- End of subroutine find_target_option
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Find the occurrences of non-space characters in a string and return their
|
|
# start and end index values(s).
|
|
#------------------------------------------------------------------------------
|
|
sub find_words_in_line
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_line_ref) = @_;
|
|
|
|
my $input_line = ${ $input_line_ref };
|
|
|
|
my $finished = $TRUE;
|
|
|
|
my $space = 0;
|
|
my $space_position = 0;
|
|
my $start_word;
|
|
my $end_word;
|
|
|
|
my @word_delimiters = ();
|
|
|
|
gp_message ("debugXL", $subr_name, "input_line = $input_line");
|
|
|
|
$finished = $FALSE;
|
|
while (not $finished)
|
|
{
|
|
$space = index ($input_line, " ", $space_position);
|
|
|
|
my $txt = "string search space_position = $space_position ";
|
|
$txt .= "space = $space";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
|
|
if ($space != -1)
|
|
{
|
|
if ($space > $space_position)
|
|
{
|
|
$start_word = $space_position;
|
|
$end_word = $space - 1;
|
|
$space_position = $space;
|
|
my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
|
|
gp_message ("debugXL", $subr_name, "string search start_word = $start_word end_word = $end_word space_position = $space_position $keyword");
|
|
push (@word_delimiters, [$start_word, $end_word]);
|
|
}
|
|
elsif ( ($space == $space_position) and ($space < length ($input_line) - 1))
|
|
{
|
|
$space = $space + 1;
|
|
$space_position = $space;
|
|
}
|
|
else
|
|
{
|
|
print "DONE\n";
|
|
$finished = $TRUE;
|
|
gp_message ("debugXL", $subr_name, "completed - finished = $finished");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$finished = $TRUE;
|
|
$start_word = $space_position;
|
|
$end_word = length ($input_line) - 1;
|
|
my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
|
|
push (@word_delimiters, [$start_word, $end_word]);
|
|
if ($keyword =~ /\s+/)
|
|
{
|
|
my $txt = "end search spaces only";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
}
|
|
else
|
|
{
|
|
my $txt = "end search start_word = $start_word ";
|
|
$txt .= "end_word = $end_word ";
|
|
$txt .= "space_position = $space_position -->$keyword<--";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
for my $i (keys @word_delimiters)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "i = $i $word_delimiters[$i][0] $word_delimiters[$i][1]");
|
|
}
|
|
|
|
return (\@word_delimiters);
|
|
|
|
} #-- End of subroutine find_words_in_line
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub function_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($outputdir, $FUNC_FILE, $metric, $LINUX_vDSO_ref) = @_;
|
|
|
|
my %LINUX_vDSO = %{ $LINUX_vDSO_ref };
|
|
|
|
my $index_val;
|
|
my $address_decimal;
|
|
my $full_address_field;
|
|
|
|
my $FUNC_FILE_NO_PC;
|
|
my $off_with_the_PC;
|
|
|
|
my $blanks;
|
|
my $lblanks;
|
|
my $lvdso_key;
|
|
my $line_regex;
|
|
|
|
my %functions_per_metric_indexes = ();
|
|
my %functions_per_metric_first_index = ();
|
|
my @order;
|
|
|
|
my ($line,$line_n,$value);
|
|
my ($df_flag,$n,$u);
|
|
my ($metric_value,$PC_Address,$routine);
|
|
my ($is_calls,$metric_ok,$name_regex,$pc_len);
|
|
my ($segment,$offset,$offy,$spaces,$rest,$not_printed,$vdso_key);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If the directory name does not end with a "/", add it.
|
|
#------------------------------------------------------------------------------
|
|
my $length_of_string = length ($outputdir);
|
|
|
|
if (rindex ($outputdir, "/") != $length_of_string-1)
|
|
{
|
|
$outputdir .= "/";
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "on input FUNC_FILE = $FUNC_FILE metric = $metric");
|
|
|
|
$is_calls = $FALSE;
|
|
$metric_ok = $TRUE;
|
|
$off_with_the_PC = rindex ($FUNC_FILE, "-PC");
|
|
$FUNC_FILE_NO_PC = substr ($FUNC_FILE, 0, $off_with_the_PC);
|
|
|
|
if ($FUNC_FILE_NO_PC eq $outputdir."calls.sort.func")
|
|
{
|
|
$FUNC_FILE_NO_PC = $outputdir."calls";
|
|
$is_calls = $TRUE;
|
|
$metric_ok = $FALSE;
|
|
}
|
|
elsif ($FUNC_FILE_NO_PC eq $outputdir."calltree.sort.func")
|
|
{
|
|
$FUNC_FILE_NO_PC = $outputdir."calltree";
|
|
$metric_ok = $FALSE;
|
|
}
|
|
elsif ($FUNC_FILE_NO_PC eq $outputdir."functions.sort.func")
|
|
{
|
|
$FUNC_FILE_NO_PC = $outputdir."functions.func";
|
|
$metric_ok = $FALSE;
|
|
}
|
|
gp_message ("debugM", $subr_name, "set FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC");
|
|
|
|
open (FUNC_FILE, "<", $FUNC_FILE)
|
|
or die ("Not able to open file $FUNC_FILE for reading - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file FUNC_FILE = $FUNC_FILE for reading");
|
|
|
|
open (FUNC_FILE_NO_PC, ">", $FUNC_FILE_NO_PC)
|
|
or die ("Not able to open file $FUNC_FILE_NO_PC for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC for writing");
|
|
|
|
open (FUNC_FILE_REGEXP, "<", "$FUNC_FILE.name-regex")
|
|
or die ("Not able to open file $FUNC_FILE.name-regex for reading - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file FUNC_FILE_REGEXP = $FUNC_FILE.name-regex for reading");
|
|
|
|
$name_regex = <FUNC_FILE_REGEXP>;
|
|
chomp ($name_regex);
|
|
close (FUNC_FILE_REGEXP);
|
|
|
|
gp_message ("debugXL", $subr_name, "name_regex = $name_regex");
|
|
|
|
$n = 0;
|
|
$u = 0;
|
|
$pc_len = 0;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Note that the double \\ is needed here. The regex used will not have these.
|
|
#------------------------------------------------------------------------------
|
|
if ($is_calls)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
# I do not see the "*" in my test output, but no harm to leave the code in.
|
|
#
|
|
# er_print * before PC for calls ! 101315
|
|
#------------------------------------------------------------------------------
|
|
$line_regex = "^(\\s*)(\\**)(\\S+)(:)(\\S+)(\\s+)(.*)";
|
|
}
|
|
else
|
|
{
|
|
$line_regex = "^(\\s*)(\\S+)(:)(\\S+)(\\s+)(.*)";
|
|
}
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." line_regex->$line_regex<-");
|
|
gp_message ("debugXL", $subr_name, "read FUNC_FILE = $FUNC_FILE");
|
|
|
|
$line_n = 0;
|
|
$index_val = 0;
|
|
while (<FUNC_FILE>)
|
|
{
|
|
$line = $_;
|
|
chomp ($line);
|
|
|
|
# gp_message ("debug", $subr_name, "FUNC_FILE: input line = $line");
|
|
|
|
$line_n++;
|
|
if ($line =~ /$line_regex/) # field 2|3 needs to be \S in case of -ve sign
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# A typical target line looks like this:
|
|
# 11:0x001492e0 6976.900 <additional_timings> _lwp_start
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "select = $line");
|
|
if ($is_calls)
|
|
{
|
|
$segment = $3;
|
|
$offset = $5;
|
|
$spaces = $6;
|
|
$rest = $7;
|
|
$PC_Address = $segment.$4.$offset; # PC Addr.
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$3 = $3");
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5");
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6");
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$7 = $7");
|
|
}
|
|
else
|
|
{
|
|
$segment = $2;
|
|
$offset = $4;
|
|
$spaces = $5;
|
|
$rest = $6;
|
|
$PC_Address = $segment.$3.$offset; # PC Addr.
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$2 = $2");
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$4 = $4");
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5");
|
|
gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6");
|
|
}
|
|
if ($segment == -1)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# presume vDSO field overflow - er_print used an inadequate format
|
|
# or the fsummary (MASTER) had the wrong format for -1?
|
|
# rats - get ahead of ourselves - should not be a field abuttal so
|
|
#------------------------------------------------------------------------------
|
|
if ($line =~ /$name_regex/)
|
|
{
|
|
if ($metric_ok)
|
|
{
|
|
$metric_value = $1; # whatever
|
|
$routine = $2;
|
|
}
|
|
else
|
|
{
|
|
$routine = $1;
|
|
}
|
|
if ($is_calls)
|
|
{
|
|
if (substr ($routine,0,1) eq "*")
|
|
{
|
|
$routine = substr ($routine,1);
|
|
}
|
|
}
|
|
for $vdso_key (keys %LINUX_vDSO)
|
|
{
|
|
if ($routine eq $LINUX_vDSO{$vdso_key})
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# presume no duplicates - at least can check offset
|
|
#------------------------------------------------------------------------------
|
|
if ($vdso_key =~ /(\d+):(\S+)/)
|
|
#------------------------------------------------------------------------------
|
|
# no -ve segments allowed and not expected
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if ($2 eq $offset)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# the real segment
|
|
#------------------------------------------------------------------------------
|
|
$segment = $1;
|
|
gp_message ("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE");
|
|
$PC_Address = $segment.":".$offset; # PC Addr.
|
|
gp_message ("debugXL", $subr_name, "vdso line ->$line");
|
|
$line = $PC_Address.(' ' x (length ($spaces)-2)).$rest;
|
|
gp_message ("debugXL", $subr_name, "becomes ->$line");
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "name_regex failure for file $FUNC_FILE");
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# a rotten exception for Linux vDSO
|
|
# With a BIG "PC Address" like 32767:0x841fecd0, the functions.sort.func_PC file
|
|
# can have lines like
|
|
#->32767:0x841fecd0161.553 527182898954 131.936 100003 __vdso_gettimeofday<-
|
|
#->32767:0x153ff810 42.460 0 0 __vdso_gettimeofday<-
|
|
#->-1:0xff600000 99.040 0 0 [vsyscall]<-
|
|
# (Real PC Address: 4294967295:0xff600000)
|
|
#-> 4294967295:0xff600000 99.040 0 0 [vsyscall]<-
|
|
#-> 9:0x00000020 49.310 0 0 <static>@0x7fff153ff600 ([vdso])<-
|
|
# Rats!
|
|
# $LINUX_vDSO{substr($order[$i]{"addressobjtext"},1)} = $order[$i]{"routine"};
|
|
#------------------------------------------------------------------------------
|
|
|
|
$not_printed = $TRUE;
|
|
for $vdso_key (keys %LINUX_vDSO)
|
|
{
|
|
if ($line =~ /^(\s*)($vdso_key)(.*)$/)
|
|
{
|
|
$blanks = 1;
|
|
$rest = 3;
|
|
$lblanks = length ($blanks);
|
|
$lvdso_key = length ($vdso_key);
|
|
$PC_Address = $vdso_key; # PC Addr.
|
|
$offy = ($lblanks+$lvdso_key < $pc_len) ? $pc_len : $lblanks+$lvdso_key;
|
|
gp_message ("debugXL", $subr_name, "offy = $offy for ->$line<-");
|
|
if ($pc_len)
|
|
{
|
|
print FUNC_FILE_NO_PC substr ($line,$offy)."\n";
|
|
$not_printed = $FALSE;
|
|
}
|
|
else
|
|
{
|
|
die ("sod1a");
|
|
}
|
|
gp_message ("debugXL", $subr_name, "vdso line ->$line");
|
|
if (substr ($line,$lblanks+$lvdso_key,1) eq " ")
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# O.K. no field abuttal
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "vdso no field abuttal line ->$line");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debugXL", $subr_name, "vdso field abuttal line ->$line");
|
|
$line = $blanks.$vdso_key." ".$rest;
|
|
}
|
|
gp_message ("debugXL", $subr_name, "becomes ->$line");
|
|
last;
|
|
}
|
|
}
|
|
if ($not_printed)
|
|
{
|
|
if ($pc_len)
|
|
{
|
|
print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n";
|
|
}
|
|
else
|
|
{
|
|
die ("sod1b");
|
|
}
|
|
$not_printed = $FALSE;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
if (!$pc_len)
|
|
{
|
|
if ($line =~ /(^\s*PC Addr.\s+)(\S+)/)
|
|
{
|
|
$pc_len = length ($1); # say 15
|
|
print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n";
|
|
}
|
|
else
|
|
{
|
|
print FUNC_FILE_NO_PC "$line\n";
|
|
}
|
|
}
|
|
else
|
|
{
|
|
if ($pc_len)
|
|
{
|
|
my $strlen = length ($line);
|
|
if ($strlen > 0 )
|
|
{
|
|
print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n";
|
|
}
|
|
else
|
|
{
|
|
print FUNC_FILE_NO_PC "\n";
|
|
}
|
|
}
|
|
else
|
|
{
|
|
die ("sod2");
|
|
}
|
|
}
|
|
next;
|
|
}
|
|
$routine = "";
|
|
if ($line =~ /$name_regex/)
|
|
{
|
|
if ($metric_ok)
|
|
{
|
|
$metric_value = $1; # whatever
|
|
$routine = $2;
|
|
}
|
|
else
|
|
{
|
|
$routine = $1;
|
|
}
|
|
}
|
|
|
|
if ($is_calls)
|
|
{
|
|
if (substr ($routine,0,1) eq "*")
|
|
{
|
|
$routine = substr ($routine,1);
|
|
}
|
|
}
|
|
if (length ($routine))
|
|
{
|
|
$order[$index_val]{"routine"} = $routine;
|
|
if ($metric_ok)
|
|
{
|
|
$order[$index_val]{"metric_value"} = $metric_value;
|
|
}
|
|
$order[$index_val]{"PC Address"} = $PC_Address;
|
|
$df_flag = 0;
|
|
if (not exists ($functions_per_metric_indexes{$routine}))
|
|
{
|
|
$functions_per_metric_indexes{$routine} = [$index_val];
|
|
}
|
|
else
|
|
{
|
|
push (@{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list
|
|
}
|
|
gp_message ("debugXL", $subr_name, "updated functions_per_metric_indexes $routine [$index_val] line = $line");
|
|
if ($PC_Address =~ /\s*(\S+):(\S+)/)
|
|
{
|
|
my ($segment,$offset);
|
|
$segment = $1;
|
|
$offset = $2;
|
|
$address_decimal = bigint::hex ($offset); # decimal
|
|
$full_address_field = '@'.$segment.":".$offset; # e.g. @2:0x0003f280
|
|
$order[$index_val]{"addressobj"} = $address_decimal;
|
|
$order[$index_val]{"addressobjtext"} = $full_address_field;
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Check uniqueness
|
|
#------------------------------------------------------------------------------
|
|
if (not exists ($functions_per_metric_first_index{$routine}{$PC_Address}))
|
|
{
|
|
$functions_per_metric_first_index{$routine}{$PC_Address} = $index_val;
|
|
$u++; #$RI
|
|
}
|
|
else
|
|
{
|
|
if (!($metric eq "calls" || $metric eq "calltree"))
|
|
{
|
|
gp_message ("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address");
|
|
}
|
|
}
|
|
|
|
$index_val++;
|
|
gp_message ("debugXL", $subr_name, "updated index_val = $index_val");
|
|
$n++;
|
|
next;
|
|
}
|
|
else
|
|
{
|
|
if ($n && length ($line))
|
|
{
|
|
my $msg = "unexpected line format in functions file $FUNC_FILE line->$line<-";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
}
|
|
close (FUNC_FILE);
|
|
close (FUNC_FILE_NO_PC);
|
|
|
|
for my $i (sort keys %functions_per_metric_indexes)
|
|
{
|
|
my $values = "";
|
|
for my $fields (sort keys @{ $functions_per_metric_indexes{$i} })
|
|
{
|
|
$values .= "$functions_per_metric_indexes{$i}[$fields] ";
|
|
}
|
|
gp_message ("debugXL", $subr_name, "on return: functions_per_metric_indexes{$i} = $values");
|
|
}
|
|
|
|
return (\@order, \%functions_per_metric_first_index, \%functions_per_metric_indexes);
|
|
|
|
} #-- End of subroutine function_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate a html header.
|
|
#------------------------------------------------------------------------------
|
|
sub generate_a_header
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($page_text_ref, $size_text_ref, $position_text_ref) = @_;
|
|
|
|
my $page_text = ${ $page_text_ref };
|
|
my $size_text = ${ $size_text_ref };
|
|
my $position_text = ${ $position_text_ref };
|
|
my $html_header;
|
|
|
|
$html_header = "<div class=\"" . $position_text . "\">\n";
|
|
$html_header .= "<". $size_text . ">\n";
|
|
$html_header .= $page_text . "\n";
|
|
$html_header .= "</". $size_text . ">\n";
|
|
$html_header .= "</div>";
|
|
|
|
gp_message ("debugXL", $subr_name, "on exit page_title = $html_header");
|
|
|
|
return (\$html_header);
|
|
|
|
} #-- End of subroutine generate_a_header
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the caller-callee information.
|
|
#------------------------------------------------------------------------------
|
|
sub generate_caller_callee
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref,
|
|
$function_address_info_ref, $addressobjtextm_ref,
|
|
$input_string_ref) = @_;
|
|
|
|
my $number_of_metrics = ${ $number_of_metrics_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
my %function_view_structure = %{ $function_view_structure_ref };
|
|
my %function_address_info = %{ $function_address_info_ref };
|
|
my %addressobjtextm = %{ $addressobjtextm_ref };
|
|
my $input_string = ${ $input_string_ref };
|
|
|
|
my @caller_callee_data = ();
|
|
my $outfile;
|
|
my $input_line;
|
|
|
|
my $fullname;
|
|
my $separator = "cuthere";
|
|
|
|
my @address_field = ();
|
|
my @fields = ();
|
|
my @function_names = ();
|
|
my @marker = ();
|
|
my @metric_values = ();
|
|
my @word_index_values = ();
|
|
my @header_lines = ();
|
|
|
|
my $all_metrics;
|
|
my $elements_in_name;
|
|
my $full_hex_address;
|
|
my $hex_address;
|
|
|
|
my $file_title;
|
|
my $page_title;
|
|
my $size_text;
|
|
my $position_text;
|
|
my @html_metric_sort_header = ();
|
|
my $html_header;
|
|
my $html_title_header;
|
|
my $html_home;
|
|
my $html_acknowledgement;
|
|
my $html_end;
|
|
my $html_line;
|
|
|
|
my $marker_target_function;
|
|
my $max_metrics_length = 0;
|
|
my $metrics_length;
|
|
my $modified_line;
|
|
my $name_regex;
|
|
my $no_of_fields;
|
|
my $routine;
|
|
my $routine_length;
|
|
my $string_length;
|
|
my $top_header;
|
|
my $total_header_lines;
|
|
my $word_index_values_ref;
|
|
my $infile;
|
|
|
|
my $outputdir = append_forward_slash ($input_string);
|
|
my $LANG = $g_locale_settings{"LANG"};
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
|
|
gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator");
|
|
gp_message ("debug", $subr_name, "outputdir = $outputdir");
|
|
|
|
$infile = $outputdir . "caller-callee-PC2";
|
|
$outfile = $outputdir . $g_html_base_file_name{"caller_callee"} . ".html";
|
|
|
|
gp_message ("debug", $subr_name, "infile = $infile outfile = $outfile");
|
|
|
|
open (CALLER_CALLEE_IN, "<", $infile)
|
|
or die ("unable to open caller file $infile for reading - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $infile for reading");
|
|
|
|
open (CALLER_CALLEE_OUT, ">", $outfile)
|
|
or die ("unable to open $outfile for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile for writing");
|
|
|
|
gp_message ("debug", $subr_name, "building caller-callee file $outfile");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate some of the structures used in the HTML output.
|
|
#------------------------------------------------------------------------------
|
|
$file_title = "Caller-callee overview";
|
|
$html_header = ${ create_html_header (\$file_title) };
|
|
$html_home = ${ generate_home_link ("right") };
|
|
|
|
$page_title = "Caller Callee View";
|
|
$size_text = "h2";
|
|
$position_text = "center";
|
|
$html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read all of the file into array with the name caller_callee_data.
|
|
#------------------------------------------------------------------------------
|
|
chomp (@caller_callee_data = <CALLER_CALLEE_IN>);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Typical structure of the input file:
|
|
#
|
|
# Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm
|
|
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
|
|
# Functions sorted by metric: Exclusive Total CPU Time
|
|
# Callers and callees sorted by metric: Attributed Total CPU Time
|
|
#
|
|
# PC Addr. Name Attr. Attr. CPU Attr. Attr.
|
|
# Total Cycles Instructions Last-Level
|
|
# CPU sec. sec. Executed Cache Misses
|
|
# 1:0x00000000 *<Total> 3.502 4.005 15396819700 24024250
|
|
# 7:0x00008070 start_thread 3.342 3.865 14500538981 23824045
|
|
# 6:0x000233a0 __libc_start_main 0.160 0.140 896280719 200205
|
|
#
|
|
# PC Addr. Name Attr. Attr. CPU Attr. Attr.
|
|
# Total Cycles Instructions Last-Level
|
|
# CPU sec. sec. Executed Cache Misses
|
|
# 2:0x000021f9 driver_mxv 3.342 3.865 14500538981 23824045
|
|
# 2:0x000021ae *mxv_core 3.342 3.865 14500538981 23824045
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Scan the input file. The first lines are assumed to be part of the header,
|
|
# so we store those. The diagnostic lines that echo some settings are also
|
|
# stored, but currently not used.
|
|
#------------------------------------------------------------------------------
|
|
my $scan_header = $FALSE;
|
|
my $scan_caller_callee_data = $FALSE;
|
|
my $data_function_block = "";
|
|
my @function_blocks = ();
|
|
my $first = $TRUE;
|
|
my @html_caller_callee = ();
|
|
my @top_level_header = ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The regexes.
|
|
#------------------------------------------------------------------------------
|
|
my $empty_line_regex = '^\s*$';
|
|
my $line_of_interest_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\**)(.*)';
|
|
my $get_hex_address_regex = '(\d+):0x(\S+)';
|
|
my $get_metric_field_regex = ')\s+([\s\d' . $decimal_separator . ']*)';
|
|
my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)';
|
|
my $sorted_by_regex = 'sorted by metric:';
|
|
my $current_regex = '^Current';
|
|
my $get_addr_offset_regex = '^@\d+:';
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the length of the first metric field across all lines. This value is
|
|
# used to pad the first metric with spaces and get the alignment right.
|
|
#
|
|
# Scan the input data and find the line(s) with metric values. A complication
|
|
# is that a function name may consists of more than one field.
|
|
#
|
|
# Note. This part could be used to parse the other elements of the input file,
|
|
# but that makes the loop very complicated. Instead, we re-scan the data
|
|
# below and process each block separately.
|
|
#
|
|
# Since this data is all in memory and relatively small, the performance should
|
|
# not suffer much, but it does improve the readability of the code.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "determine the maximum length of the first field");
|
|
|
|
$g_max_length_first_metric = 0;
|
|
my @hex_addresses = ();
|
|
my @special_marker = ();
|
|
my @the_function_name = ();
|
|
my @the_metrics = ();
|
|
my @length_first_metric = ();
|
|
|
|
for (my $line = 0; $line <= $#caller_callee_data; $line++)
|
|
{
|
|
my $input_line = $caller_callee_data[$line];
|
|
|
|
if ($input_line =~ /$line_of_interest_regex/)
|
|
{
|
|
if (defined ($1) and defined ($2) and defined ($3))
|
|
#------------------------------------------------------------------------------
|
|
# This is a line of interest, since it has the address, the function name and
|
|
# the values for the metrics. Examples of valid lines are:
|
|
#
|
|
# 2:0x00005028 *xfree_large 0. 0
|
|
# 12:0x0004c2b0 munmap 0.143 6402086
|
|
# 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0
|
|
#
|
|
# The function name marked with a * is the current target.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my $full_hex_address = $1;
|
|
my $marker = $2;
|
|
my $remaining_line = $3;
|
|
|
|
if ($full_hex_address =~ /$get_hex_address_regex/)
|
|
{
|
|
$hex_address = "0x" . $2;
|
|
push (@hex_addresses, $hex_address);
|
|
gp_message ("debugXL", $subr_name, "pushed $hex_address");
|
|
}
|
|
else
|
|
{
|
|
my $msg = "full_hex_address = $full_hex_address has an unknown format";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
if ($marker eq "*")
|
|
{
|
|
push (@special_marker, "*");
|
|
}
|
|
else
|
|
{
|
|
push (@special_marker, "X");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "input_line = $input_line has an unknown format";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
my @fields_in_line = split (" ", $input_line);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We stripped the address and marker (if any), off, so this string starts with
|
|
# the function name.
|
|
#------------------------------------------------------------------------------
|
|
my $remainder = $3;
|
|
my $number_of_fields = scalar (@fields_in_line);
|
|
my $words_in_function_name = $number_of_fields - $number_of_metrics - 1;
|
|
my @remainder_array = split (" ", $remainder);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If the first metric is 0. (or 0, depending on the locale), the calculation
|
|
# of the length needs to be adjusted, because 0. is really 0.000.
|
|
#
|
|
# While we could easily add 3 to the length, we assign a symbolic value to the
|
|
# first metric (ZZZ) and then compute the length. This makes things clearer.
|
|
# I hope ;-)
|
|
#------------------------------------------------------------------------------
|
|
my $first_metric = $remainder_array[$words_in_function_name];
|
|
if ($first_metric =~ /^0$decimal_separator$/)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "fixed up $first_metric");
|
|
$first_metric = "0.ZZZ";
|
|
}
|
|
push (@length_first_metric, length ($first_metric));
|
|
|
|
my $txt = "words in function name = $words_in_function_name ";
|
|
$txt .= "first_metric = $first_metric length = ";
|
|
$txt .= length ($first_metric);
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the regex for the metrics.
|
|
#
|
|
# TBD: This should be an attribute of the function and be done once only.
|
|
#------------------------------------------------------------------------------
|
|
my $m_regex = '(\S+';
|
|
for my $f (2 .. $words_in_function_name)
|
|
{
|
|
$m_regex .= '\s+\S+';
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# This last part captures all the metric values.
|
|
#------------------------------------------------------------------------------
|
|
$m_regex .= $get_metric_field_regex;
|
|
gp_message ("debugXL", $subr_name, "m_regex = $m_regex");
|
|
gp_message ("debugXL", $subr_name, "remainder = $remainder");
|
|
|
|
if ($remainder =~ /$m_regex/)
|
|
{
|
|
my $func_name = $1;
|
|
my $its_metrics = $2;
|
|
my $msg = "found the info - func_name = " . $func_name .
|
|
" its metrics = " . $its_metrics;
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
push (@the_function_name, $func_name);
|
|
push (@the_metrics, $its_metrics);
|
|
}
|
|
else
|
|
{
|
|
my $msg = "remainder string $remainder has an unrecognized format";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
$g_max_length_first_metric = max ($g_max_length_first_metric, length ($first_metric));
|
|
|
|
my $msg = "first_metric = $first_metric " .
|
|
"g_max_length_first_metric = $g_max_length_first_metric";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
}
|
|
gp_message ("debugXL", $subr_name, "final: g_max_length_first_metric = $g_max_length_first_metric");
|
|
gp_message ("debugXL", $subr_name, "#hex_addresses = $#hex_addresses");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Main loop over the input data.
|
|
#------------------------------------------------------------------------------
|
|
my $index_start = 0; # 1
|
|
my $index_end = -1; # 0
|
|
for (my $line = 0; $line <= $#caller_callee_data; $line++)
|
|
{
|
|
my $input_line = $caller_callee_data[$line];
|
|
|
|
if ($input_line =~ /$header_name_regex/)
|
|
{
|
|
$scan_header = $TRUE;
|
|
gp_message ("debugXL", $subr_name, "line = $line encountered start of the header scan_header = $scan_header first = $first");
|
|
}
|
|
elsif (($input_line =~ /$sorted_by_regex/) or ($input_line =~ /$current_regex/))
|
|
{
|
|
my $msg = "line = " . $line . " captured top level header: " .
|
|
"input_line = " . $input_line;
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
push (@top_level_header, $input_line);
|
|
}
|
|
elsif ($input_line =~ /$line_of_interest_regex/)
|
|
{
|
|
$index_end++;
|
|
$scan_header = $FALSE;
|
|
$scan_caller_callee_data = $TRUE;
|
|
$data_function_block .= $separator . $input_line;
|
|
|
|
my $msg = "line = $line updated index_end = $index_end";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
elsif (($input_line =~ /$empty_line_regex/) and ($scan_caller_callee_data))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# An empty line is interpreted as the end of the current block and we process
|
|
# this, including the generation of the html code for this block.
|
|
#------------------------------------------------------------------------------
|
|
$first = $FALSE;
|
|
$scan_caller_callee_data = $FALSE;
|
|
|
|
gp_message ("debugXL", $subr_name, "new block");
|
|
gp_message ("debugXL", $subr_name, "line = $line index_start = $index_start");
|
|
gp_message ("debugXL", $subr_name, "line = $line index_end = $index_end");
|
|
gp_message ("debugXL", $subr_name, "line = $line data_function_block = $data_function_block");
|
|
|
|
push (@function_blocks, $data_function_block);
|
|
my ($html_block_prologue_ref, $html_code_function_block_ref) =
|
|
generate_html_function_blocks (
|
|
\$index_start,
|
|
\$index_end,
|
|
\@hex_addresses,
|
|
\@the_metrics,
|
|
\@length_first_metric,
|
|
\@special_marker,
|
|
\@the_function_name,
|
|
\$separator,
|
|
$number_of_metrics_ref,
|
|
\$data_function_block,
|
|
$function_info_ref,
|
|
$function_view_structure_ref);
|
|
|
|
my @html_block_prologue = @{ $html_block_prologue_ref };
|
|
my @html_code_function_block = @{ $html_code_function_block_ref };
|
|
|
|
for my $lines (0 .. $#html_code_function_block)
|
|
{
|
|
my $msg = "final html_code_function_block[" . $lines . "] = " .
|
|
$html_code_function_block[$lines];
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
|
|
$data_function_block = "";
|
|
|
|
push (@html_caller_callee, @html_block_prologue);
|
|
push (@html_caller_callee, @header_lines);
|
|
push (@html_caller_callee, @html_code_function_block);
|
|
|
|
$index_start = $index_end + 1;
|
|
$index_end = $index_start - 1;
|
|
gp_message ("debugXL", $subr_name, "line = $line reset index_start = $index_start");
|
|
gp_message ("debugXL", $subr_name, "line = $line reset index_end = $index_end");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Only capture the first header. They are all identical.
|
|
#------------------------------------------------------------------------------
|
|
if ($scan_header and $first)
|
|
{
|
|
if (defined ($4))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# This group is only defined for the first line of the header.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "header1 = $4");
|
|
gp_message ("debugXL", $subr_name, "extra = $3 spaces=x$2x");
|
|
my $newline = "<b>" . $4 . "</b>";
|
|
push (@header_lines, $newline);
|
|
}
|
|
elsif ($input_line =~ /\s*(.*)/)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Capture the subsequent header lines.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "headern = $1");
|
|
my $newline = "<b>" . $1 . "</b>";
|
|
push (@header_lines, $newline);
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
for my $i (0 .. $#header_lines)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]");
|
|
}
|
|
for my $i (0 .. $#function_blocks)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "function_blocks[$i] = $function_blocks[$i]");
|
|
}
|
|
|
|
my $number_of_blocks = $#function_blocks + 1;
|
|
gp_message ("debugXL", $subr_name, "There are " . $number_of_blocks . " function blocks:");
|
|
|
|
for my $i (0 .. $#function_blocks)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The split produces an empty first field and is why we skip the first field.
|
|
#------------------------------------------------------------------------------
|
|
## my @entries = split ("cuthere", $function_blocks[$i]);
|
|
my @entries = split ($separator, $function_blocks[$i]);
|
|
for my $k (1 .. $#entries)
|
|
{
|
|
my $msg = "entries[" . $k . "] = ". $entries[$k];
|
|
gp_message ("debugXL", $subr_name, $k . $msg);
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse and process the individual function blocks.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (0 .. $#function_blocks)
|
|
{
|
|
my $msg = "function_blocks[" . $i . "] = ". $function_blocks[$i];
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
#------------------------------------------------------------------------------
|
|
# This split produces an empty first field. This is why skip this.
|
|
#------------------------------------------------------------------------------
|
|
my @entries = split ($separator, $function_blocks[$i]);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# An example of @entries:
|
|
# <empty>
|
|
# 6:0x0003ad20 drand48 0.100 0.084 768240570 0
|
|
# 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0
|
|
# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
|
|
#------------------------------------------------------------------------------
|
|
for my $k (1 .. $#entries)
|
|
{
|
|
my $input_line = $entries[$k];
|
|
|
|
my $msg = "input_line = entries[" . $k . "] = ". $entries[$k];
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
@fields = split (" ", $input_line);
|
|
|
|
$no_of_fields = $#fields + 1;
|
|
$elements_in_name = $no_of_fields - $number_of_metrics - 1;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Too restrictive.
|
|
# CHECK CODE IN GENERATE_CALLER_CALLEE
|
|
#------------------------------------------------------------------------------
|
|
if ($elements_in_name == 1)
|
|
{
|
|
$name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])(\S+)\s+(.*)';
|
|
}
|
|
elsif ($elements_in_name == 2)
|
|
{
|
|
$name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])((\S+)\s+(\S+))\s+(.*)';
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Handle this better in case a function entry has more than 2 words.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my $msg = "$elements_in_name elements in name exceeds limit";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
if ($input_line =~ /$name_regex/)
|
|
{
|
|
$full_hex_address = $1;
|
|
$marker_target_function = $2;
|
|
$routine = $3;
|
|
if ($elements_in_name == 1)
|
|
{
|
|
$all_metrics = $4;
|
|
}
|
|
elsif ($elements_in_name == 2)
|
|
{
|
|
$all_metrics = $6;
|
|
}
|
|
|
|
$metrics_length = length ($all_metrics);
|
|
$max_metrics_length = max ($max_metrics_length, $metrics_length);
|
|
|
|
if ($full_hex_address =~ /(\d+):0x(\S+)/)
|
|
{
|
|
$hex_address = "0x" . $2;
|
|
}
|
|
push (@marker, $marker_target_function);
|
|
push (@address_field, $hex_address);
|
|
$modified_line = $all_metrics . " " . $routine;
|
|
push (@metric_values, $all_metrics);
|
|
gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line");
|
|
push (@function_names, $routine);
|
|
}
|
|
}
|
|
|
|
$total_header_lines = $#header_lines + 1;
|
|
gp_message ("debugXL", $subr_name, "total_header_lines = $total_header_lines");
|
|
|
|
gp_message ("debugXL", $subr_name, "Final output");
|
|
for my $i (keys @header_lines)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "$header_lines[$i]");
|
|
}
|
|
for my $i (0 .. $#function_names)
|
|
{
|
|
my $msg = $metric_values[$i] . " " . $marker[$i] .
|
|
$function_names[$i] . "(" . $address_field[$i] . ")";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Check if this function has multiple occurrences.
|
|
# TBD: Replace by the function call for this.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "check for multiple occurrences");
|
|
for my $i (0 .. $#function_names)
|
|
{
|
|
my $current_address = $address_field[$i];
|
|
my $found_a_match;
|
|
my $ref_index;
|
|
my $alt_name;
|
|
$routine = $function_names[$i];
|
|
$alt_name = $routine;
|
|
gp_message ("debugXL", $subr_name, "checking for routine = $routine");
|
|
if (exists ($g_multi_count_function{$routine}))
|
|
{
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!!
|
|
#------------------------------------------------------------------------------
|
|
|
|
$found_a_match = $FALSE;
|
|
gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
|
|
for my $ref (keys @{ $g_map_function_to_index{$routine} })
|
|
{
|
|
$ref_index = $g_map_function_to_index{$routine}[$ref];
|
|
|
|
gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
|
|
gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
|
|
|
|
my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
|
|
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
|
|
|
|
$addr_offset =~ s/$get_addr_offset_regex//;
|
|
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
|
|
if ($addr_offset eq $current_address)
|
|
{
|
|
$found_a_match = $TRUE;
|
|
last;
|
|
}
|
|
}
|
|
gp_message ("debugXL", $subr_name, "$function_info[$ref_index]{'alt_name'} is the actual function for i = $i $found_a_match");
|
|
$alt_name = $function_info[$ref_index]{'alt_name'};
|
|
}
|
|
gp_message ("debugXL", $subr_name, "alt_name = $alt_name");
|
|
}
|
|
gp_message ("debugXL", $subr_name, "completed check for multiple occurrences");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Figure out the column width. Since the columns in the header may include
|
|
# spaces, we use the first line with metrics for this.
|
|
#------------------------------------------------------------------------------
|
|
my $top_header = $metric_values[0];
|
|
my $word_index_values_ref = find_words_in_line (\$top_header);
|
|
my @word_index_values = @{ $word_index_values_ref };
|
|
|
|
# $i = 0 0 4
|
|
# $i = 1 10 14
|
|
# $i = 2 21 31
|
|
# $i = 3 35 42
|
|
for my $i (keys @word_index_values)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "i = $i $word_index_values[$i][0] $word_index_values[$i][1]");
|
|
}
|
|
}
|
|
|
|
push (@html_metric_sort_header, "<i>");
|
|
for my $i (0 .. $#top_level_header)
|
|
{
|
|
$html_line = $top_level_header[$i] . "<br>";
|
|
push (@html_metric_sort_header, $html_line);
|
|
}
|
|
push (@html_metric_sort_header, "</i>");
|
|
|
|
print CALLER_CALLEE_OUT $html_header;
|
|
print CALLER_CALLEE_OUT $html_home;
|
|
print CALLER_CALLEE_OUT $html_title_header;
|
|
print CALLER_CALLEE_OUT "$_" for @g_html_experiment_stats;
|
|
## print CALLER_CALLEE_OUT "<br>\n";
|
|
## print CALLER_CALLEE_OUT "$_\n" for @html_metric_sort_header;
|
|
print CALLER_CALLEE_OUT "<pre>\n";
|
|
print CALLER_CALLEE_OUT "$_\n" for @html_caller_callee;
|
|
print CALLER_CALLEE_OUT "</pre>\n";
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Get the acknowledgement, return to main link, and final html statements.
|
|
#-------------------------------------------------------------------------------
|
|
$html_home = ${ generate_home_link ("left") };
|
|
$html_acknowledgement = ${ create_html_credits () };
|
|
$html_end = ${ terminate_html_document () };
|
|
|
|
print CALLER_CALLEE_OUT $html_home;
|
|
print CALLER_CALLEE_OUT "<br>\n";
|
|
print CALLER_CALLEE_OUT $html_acknowledgement;
|
|
print CALLER_CALLEE_OUT $html_end;
|
|
|
|
close (CALLER_CALLEE_OUT);
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine generate_caller_callee
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the html version of the disassembly file.
|
|
#
|
|
# Note to self (TBD)
|
|
# https://software.intel.com/content/www/us/en/develop/blogs/intel-release-new-technology-specifications-protect-rop-attacks.html
|
|
#------------------------------------------------------------------------------
|
|
sub generate_dis_html
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($target_function_ref, $number_of_metrics_ref, $function_info_ref,
|
|
$function_address_and_index_ref, $outputdir_ref, $func_ref,
|
|
$source_line_ref, $metric_ref, $addressobj_index_ref) = @_;
|
|
|
|
my $target_function = ${ $target_function_ref };
|
|
my $number_of_metrics = ${ $number_of_metrics_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
my %function_address_and_index = %{ $function_address_and_index_ref };
|
|
my $outputdir = ${ $outputdir_ref };
|
|
my $func = ${ $func_ref };
|
|
my @source_line = @{ $source_line_ref };
|
|
my @metric = @{ $metric_ref };
|
|
my %addressobj_index = %{ $addressobj_index_ref };
|
|
|
|
my $dec_instruction_start;
|
|
my $dec_instruction_end;
|
|
my $hex_instruction_start;
|
|
my $hex_instruction_end;
|
|
|
|
my @colour_line = ();
|
|
my $hot_line;
|
|
my $metric_values;
|
|
my $src_line;
|
|
my $dec_instr_address;
|
|
my $instruction;
|
|
my $operands;
|
|
|
|
my $html_new_line = "<br>";
|
|
my $add_new_line_before;
|
|
my $add_new_line_after;
|
|
my $address_key;
|
|
my $boldface;
|
|
my $file;
|
|
my $filename = $func;
|
|
my $func_name;
|
|
my $orig_hex_instr_address;
|
|
my $hex_instr_address;
|
|
my $index_string;
|
|
my $input_metric;
|
|
my $linenumber;
|
|
my $name;
|
|
my $last_address;
|
|
my $last_address_in_hex;
|
|
|
|
my $file_title;
|
|
my $html_header;
|
|
my $html_home;
|
|
my $html_end;
|
|
|
|
my $branch_regex = $g_arch_specific_settings{"regex"};
|
|
my $convert_to_dot = $g_locale_settings{"convert_to_dot"};
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
|
|
my $linksubexp = $g_arch_specific_settings{"linksubexp"};
|
|
my $subexp = $g_arch_specific_settings{"subexp"};
|
|
|
|
my $is_empty;
|
|
|
|
my %branch_target = ();
|
|
my %branch_target_no_ref = ();
|
|
my @disassembly_file = ();
|
|
my %extended_branch_target = ();
|
|
my %inverse_branch_target = ();
|
|
my @metrics = ();
|
|
my @modified_html = ();
|
|
|
|
my $branch_target_ref;
|
|
my $extended_branch_target_ref;
|
|
my $branch_target_no_ref_ref;
|
|
|
|
my $branch_address;
|
|
my $dec_branch_address;
|
|
my $found_it;
|
|
my $found_it_ref;
|
|
my $func_name_in_dis_file;
|
|
my $hex_branch_target;
|
|
my $instruction_address;
|
|
my $instruction_offset;
|
|
my $link;
|
|
my $modified_line;
|
|
my $raw_hex_branch_target;
|
|
my $src_line_ref;
|
|
my $threshold_line;
|
|
my $html_dis_out = $func . ".html";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The regex section.
|
|
#------------------------------------------------------------------------------
|
|
my $call_regex = '.*([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)';
|
|
my $line_of_interest_regex = '^#*\s+([\d' . $decimal_separator . '\s+]+)\[\s*(\d+|\?)\]';
|
|
my $white_space_regex = '\s+';
|
|
my $first_integer_regex = '^\d+$';
|
|
my $integer_regex = '\d+';
|
|
my $qmark_regex = '\?';
|
|
my $src_regex = '(\s*)(\d+)\.(.*)';
|
|
my $function_regex = '^(\s*)<Function:\s(.*)>';
|
|
my $end_src_header_regex = "(^\\s+)(\\d+)\\.\\s+(.*)";
|
|
my $end_dis_header_regex = "(^\\s+)(<Function: )(.*)>";
|
|
my $control_flow_1_regex = 'j[a-z]+';
|
|
my $control_flow_2_regex = 'call';
|
|
my $control_flow_3_regex = 'ret';
|
|
|
|
## my $function_call_regex2 = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*';
|
|
## my $endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])';
|
|
#------------------------------------------------------------------------------
|
|
# Dynamic. Computed below.
|
|
#
|
|
# TBD: Try to move these up.
|
|
#------------------------------------------------------------------------------
|
|
my $dis_regex;
|
|
my $metric_regex;
|
|
|
|
gp_message ("debug", $subr_name, "g_branch_regex = $g_branch_regex");
|
|
gp_message ("debug", $subr_name, "call_regex = $call_regex");
|
|
gp_message ("debug", $subr_name, "g_function_call_v2_regex = $g_function_call_v2_regex");
|
|
|
|
my $the_title = set_title ($function_info_ref, $func, "disassembly");
|
|
|
|
gp_message ("debug", $subr_name, "the_title = $the_title");
|
|
|
|
$file_title = $the_title;
|
|
$html_header = ${ create_html_header (\$file_title) };
|
|
$html_home = ${ generate_home_link ("right") };
|
|
|
|
push (@modified_html, $html_header);
|
|
push (@modified_html, $html_home);
|
|
push (@modified_html, "<pre>");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Open the input and output files.
|
|
#------------------------------------------------------------------------------
|
|
open (INPUT_DISASSEMBLY, "<", $filename)
|
|
or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'");
|
|
gp_message ("debug", $subr_name , "opened file $filename for reading");
|
|
|
|
open (HTML_OUTPUT, ">", $html_dis_out)
|
|
or die ("$subr_name - unable to open file $html_dis_out for writing: '$!'");
|
|
gp_message ("debug", $subr_name , "opened file $html_dis_out for writing");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the file is empty
|
|
#------------------------------------------------------------------------------
|
|
$is_empty = is_file_empty ($filename);
|
|
if ($is_empty)
|
|
{
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The input file is empty. Write a message in the html file and exit.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name ,"file $filename is empty");
|
|
|
|
my $comment = "No disassembly generated by $tool_name - file $filename is empty";
|
|
my $gp_error_file = $outputdir . "gp-listings.err";
|
|
|
|
my $html_empty_file_ref = html_text_empty_file (\$comment, \$gp_error_file);
|
|
my @html_empty_file = @{ $html_empty_file_ref };
|
|
|
|
print HTML_OUTPUT "$_\n" for @html_empty_file;
|
|
|
|
close (HTML_OUTPUT);
|
|
|
|
return (\@source_line);
|
|
}
|
|
else
|
|
{
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read the file into memory.
|
|
#------------------------------------------------------------------------------
|
|
chomp (@disassembly_file = <INPUT_DISASSEMBLY>);
|
|
gp_message ("debug", $subr_name ,"read file $filename into memory");
|
|
}
|
|
|
|
my $max_length_first_metric = 0;
|
|
my $src_line_no;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# First scan through the assembly listing.
|
|
#------------------------------------------------------------------------------
|
|
for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++)
|
|
{
|
|
my $input_line = $disassembly_file[$line_no];
|
|
gp_message ("debugXL", $subr_name, "[line $line_no] $input_line");
|
|
|
|
if ($input_line =~ /$line_of_interest_regex/)
|
|
{
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Found a matching line. Examples are:
|
|
# 0.370 [37] 4021d1: addsd %xmm0,%xmm1
|
|
# ## 1.001 [36] 4021d5: add $0x1,%rax
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "selected line \$1 = $1 \$2 = $2");
|
|
|
|
if (defined ($2) and defined($1))
|
|
{
|
|
@metrics = split (/$white_space_regex/ ,$1);
|
|
$src_line_no = $2;
|
|
}
|
|
else
|
|
{
|
|
my $msg = "$input_line has an unexpected format";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Compute the maximum length of the first metric and pad the field from the
|
|
# left later on. The fractional part is ignored.
|
|
#------------------------------------------------------------------------------
|
|
my $first_metric = $metrics[0];
|
|
my $new_length;
|
|
if ($first_metric =~ /$first_integer_regex/)
|
|
{
|
|
$new_length = length ($first_metric);
|
|
}
|
|
else
|
|
{
|
|
my @fields = split (/$decimal_separator/, $first_metric);
|
|
$new_length = length ($fields[0]);
|
|
}
|
|
$max_length_first_metric = max ($max_length_first_metric, $new_length);
|
|
my $msg;
|
|
$msg = "first_metric = $first_metric " .
|
|
"max_length_first_metric = $max_length_first_metric";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
if ($src_line_no !~ /$qmark_regex/)
|
|
#------------------------------------------------------------------------------
|
|
# The source code line number is known and is stored.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$source_line[$line_no] = $src_line_no;
|
|
my $msg;
|
|
$msg = "found an instruction with a source line ref: ";
|
|
$msg .= "source_line[$line_no] = $source_line[$line_no]";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check for function calls. If found, get the address offset from $4 and
|
|
# compute the target address.
|
|
#------------------------------------------------------------------------------
|
|
($found_it_ref, $branch_target_ref, $extended_branch_target_ref) =
|
|
check_and_proc_dis_func_call (
|
|
\$input_line,
|
|
\$line_no,
|
|
\%branch_target,
|
|
\%extended_branch_target);
|
|
$found_it = ${ $found_it_ref };
|
|
|
|
if ($found_it)
|
|
{
|
|
%branch_target = %{ $branch_target_ref };
|
|
%extended_branch_target = %{ $extended_branch_target_ref };
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Look for a branch instruction, or the special endbr32/endbr64 instruction
|
|
# that is also considered to be a branch target. Note that the latter is x86
|
|
# specific.
|
|
#------------------------------------------------------------------------------
|
|
($found_it_ref, $branch_target_ref, $extended_branch_target_ref,
|
|
$branch_target_no_ref_ref) = check_and_proc_dis_branches (
|
|
\$input_line,
|
|
\$line_no,
|
|
\%branch_target,
|
|
\%extended_branch_target,
|
|
\%branch_target_no_ref);
|
|
$found_it = ${ $found_it_ref };
|
|
|
|
if ($found_it)
|
|
{
|
|
%branch_target = %{ $branch_target_ref };
|
|
%extended_branch_target = %{ $extended_branch_target_ref };
|
|
%branch_target_no_ref = %{ $branch_target_no_ref_ref };
|
|
}
|
|
}
|
|
} #-- End of loop over line_no
|
|
|
|
%inverse_branch_target = reverse (%extended_branch_target);
|
|
|
|
gp_message ("debug", $subr_name, "generated inverse of branch target structure");
|
|
gp_message ("debug", $subr_name, "completed parsing file $filename");
|
|
|
|
for my $key (sort keys %branch_target)
|
|
{
|
|
gp_message ("debug", $subr_name, "branch_target{$key} = $branch_target{$key}");
|
|
}
|
|
for my $key (sort keys %extended_branch_target)
|
|
{
|
|
gp_message ("debug", $subr_name, "extended_branch_target{$key} = $extended_branch_target{$key}");
|
|
}
|
|
for my $key (sort keys %inverse_branch_target)
|
|
{
|
|
gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}");
|
|
}
|
|
for my $key (sort keys %branch_target_no_ref)
|
|
{
|
|
gp_message ("debug", $subr_name, "branch_target_no_ref{$key} = $branch_target_no_ref{$key}");
|
|
$inverse_branch_target{$key} = $key;
|
|
}
|
|
for my $key (sort keys %inverse_branch_target)
|
|
{
|
|
gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process the disassembly.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Dynamically generate the regexes.
|
|
#------------------------------------------------------------------------------
|
|
$metric_regex = '';
|
|
for my $metric_used (1 .. $number_of_metrics)
|
|
{
|
|
$metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+';
|
|
}
|
|
|
|
$dis_regex = '^(#{2}|\s{2})\s+';
|
|
$dis_regex .= '(.*)';
|
|
## $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)\s+(.*)';
|
|
$dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)(.*)';
|
|
|
|
gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex");
|
|
gp_message ("debugXL", $subr_name, "dis_regex = $dis_regex");
|
|
gp_message ("debugXL", $subr_name, "src_regex = $src_regex");
|
|
gp_message ("debugXL", $subr_name, "contents of lines array");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Identify the header lines. Make the minimal assumptions.
|
|
#
|
|
# In both cases, the first line after the header has whitespace. This is
|
|
# followed by:
|
|
#
|
|
# - A source line file has "<line_no>."
|
|
# - A dissasembly file has "<Function:"
|
|
#
|
|
# These are the characteristics we use below.
|
|
#------------------------------------------------------------------------------
|
|
for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++)
|
|
{
|
|
my $input_line = $disassembly_file[$line_no];
|
|
gp_message ("debugXL", $subr_name, "[line $line_no] $input_line");
|
|
|
|
if ($input_line =~ /$end_src_header_regex/)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "header time is over - hit source line\n");
|
|
gp_message ("debugXL", $subr_name, "$1 $2 $3\n");
|
|
last;
|
|
}
|
|
if ($input_line =~ /$end_dis_header_regex/)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "header time is over - hit disassembly line\n");
|
|
last;
|
|
}
|
|
push (@modified_html, "<i>" . $input_line . "</i>");
|
|
|
|
}
|
|
my $line_index = scalar (@modified_html);
|
|
gp_message ("debugXL", $subr_name, "final line_index = $line_index");
|
|
|
|
for (my $line_no=0; $line_no <= $line_index-1; $line_no++)
|
|
{
|
|
my $msg = " modified_html[$line_no] = $modified_html[$line_no]";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Source line:
|
|
# 20. for (int64_t r=0; r<repeat_count; r++) {
|
|
#
|
|
# Disassembly:
|
|
# 0.340 [37] 401fec: addsd %xmm0,%xmm1
|
|
# ## 1.311 [36] 401ff0: addq $1,%rax
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Find the hot PCs and store them.
|
|
#------------------------------------------------------------------------------
|
|
my @hot_program_counters = ();
|
|
my @transposed_hot_pc = ();
|
|
my @max_metric_values = ();
|
|
|
|
gp_message ("debug", $subr_name, "determine the maximum metric values");
|
|
for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
|
|
{
|
|
my $input_line = $disassembly_file[$line_no];
|
|
|
|
if ( $input_line =~ /$dis_regex/ )
|
|
{
|
|
## if ( defined ($1) and defined ($2) and defined ($3) and
|
|
## defined ($4) and defined ($5) and defined ($6) )
|
|
if ( defined ($1) and defined ($2) and defined ($3) and
|
|
defined ($4) and defined ($5) )
|
|
{
|
|
$hot_line = $1;
|
|
$metric_values = $2;
|
|
$src_line = $3;
|
|
$dec_instr_address = bigint::hex ($4);
|
|
$instruction = $5;
|
|
if (defined ($6))
|
|
{
|
|
my $white_space_regex = '\s*';
|
|
$operands = $6;
|
|
$operands =~ s/$white_space_regex//;
|
|
}
|
|
|
|
if ($hot_line eq "##")
|
|
{
|
|
my @metrics = split (" ", $metric_values);
|
|
push (@hot_program_counters, [@metrics]);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
for my $row (keys @hot_program_counters)
|
|
{
|
|
my $msg = "$filename row[" . $row . "] = ";
|
|
for my $col (keys @{$hot_program_counters[$row]})
|
|
{
|
|
$msg .= "$hot_program_counters[$row][$col] ";
|
|
$transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col];
|
|
}
|
|
gp_message ("debugXL", $subr_name, "hot PC = $msg");
|
|
}
|
|
for my $row (keys @transposed_hot_pc)
|
|
{
|
|
my $msg = "$filename row[" . $row . "] = ";
|
|
for my $col (keys @{$transposed_hot_pc[$row]})
|
|
{
|
|
$msg .= "$transposed_hot_pc[$row][$col] ";
|
|
}
|
|
gp_message ("debugXL", $subr_name, "$filename transposed = $msg");
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Get the maximum metric values and if integer, convert to floating-point.
|
|
# Since it is easier, we transpose the array and access it over the columns.
|
|
#------------------------------------------------------------------------------
|
|
for my $row (0 .. $#transposed_hot_pc)
|
|
{
|
|
my $max_val = 0;
|
|
for my $col (0 .. $#{$transposed_hot_pc[$row]})
|
|
{
|
|
$max_val = max ($transposed_hot_pc[$row][$col], $max_val);;
|
|
}
|
|
if ($max_val =~ /$integer_regex/)
|
|
{
|
|
$max_val = sprintf ("%f", $max_val);
|
|
}
|
|
gp_message ("debugXL", $subr_name, "$filename row = $row max_val = $max_val");
|
|
push (@max_metric_values, $max_val);
|
|
}
|
|
|
|
for my $metric (0 .. $#max_metric_values)
|
|
{
|
|
my $msg = "$filename maximum[$metric] = $max_metric_values[$metric]";
|
|
gp_message ("debugM", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD - Integrate this better.
|
|
#
|
|
# Scan the instructions to find the instruction address range. This is used
|
|
# to determine if a branch is external to this function.
|
|
#------------------------------------------------------------------------------
|
|
$dec_instruction_start = undef;
|
|
$dec_instruction_end = undef;
|
|
for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
|
|
{
|
|
my $input_line = $disassembly_file[$line_no];
|
|
if ( $input_line =~ /$dis_regex/ )
|
|
{
|
|
# if ( defined ($1) and defined ($2) and defined ($3) and
|
|
## defined ($4) and defined ($5) and defined ($6) )
|
|
if ( defined ($1) and defined ($2) and defined ($3) and
|
|
defined ($4) and defined ($5) )
|
|
{
|
|
$hot_line = $1;
|
|
$metric_values = $2;
|
|
$src_line = $3;
|
|
$dec_instr_address = bigint::hex ($4);
|
|
$instruction = $5;
|
|
## $operands = $6;
|
|
if (defined ($6))
|
|
{
|
|
my $white_space_regex = '\s*';
|
|
$operands = $6;
|
|
$operands =~ s/$white_space_regex//;
|
|
}
|
|
|
|
if (defined ($dec_instruction_start))
|
|
{
|
|
if ($dec_instr_address < $dec_instruction_start)
|
|
{
|
|
$dec_instruction_start = $dec_instr_address;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$dec_instruction_start = $dec_instr_address;
|
|
}
|
|
if (defined ($dec_instruction_end))
|
|
{
|
|
if ($dec_instr_address > $dec_instruction_end)
|
|
{
|
|
$dec_instruction_end = $dec_instr_address;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$dec_instruction_end = $dec_instr_address;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if (defined ($dec_instruction_start) and defined ($dec_instruction_end))
|
|
{
|
|
$hex_instruction_start = sprintf ("%x", $dec_instruction_start);
|
|
$hex_instruction_end = sprintf ("%x", $dec_instruction_end);
|
|
|
|
my $msg;
|
|
$msg = "$filename $func dec_instruction_start = " .
|
|
"$dec_instruction_start (0x$hex_instruction_start)";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
$msg = "$filename $func dec_instruction_end = " .
|
|
"$dec_instruction_end (0x$hex_instruction_end)";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is where all the results from above come together.
|
|
#------------------------------------------------------------------------------
|
|
for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
|
|
{
|
|
my $input_line = $disassembly_file[$line_no];
|
|
gp_message ("debugXL", $subr_name, "input_line[$line_no] = $input_line");
|
|
if ( $input_line =~ /$dis_regex/ )
|
|
{
|
|
gp_message ("debugXL", $subr_name, "found a disassembly line: $input_line");
|
|
|
|
if ( defined ($1) and defined ($2) and defined ($3) and
|
|
defined ($4) and defined ($5) )
|
|
{
|
|
# $branch_target{$hex_branch_target} = 1;
|
|
# $extended_branch_target{$instruction_address} = $raw_hex_branch_target;
|
|
$hot_line = $1;
|
|
$metric_values = $2;
|
|
$src_line = $3;
|
|
$orig_hex_instr_address = $4;
|
|
$instruction = $5;
|
|
## $operands = $6;
|
|
|
|
my $msg = "disassembly line: $1 $2 $3 $4 $5";
|
|
if (defined ($6))
|
|
{
|
|
$msg .= " \$6 = $6";
|
|
my $white_space_regex = '\s*';
|
|
$operands = $6;
|
|
$operands =~ s/$white_space_regex//;
|
|
}
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Pad the line with the metrics to ensure correct alignment.
|
|
#------------------------------------------------------------------------------
|
|
my $the_length;
|
|
my @split_metrics = split (" ", $metric_values);
|
|
my $first_metric = $split_metrics[0];
|
|
## if ($first_metric =~ /^\d+$/)
|
|
if ($first_metric =~ /$first_integer_regex/)
|
|
{
|
|
$the_length = length ($first_metric);
|
|
}
|
|
else
|
|
{
|
|
my @fields = split (/$decimal_separator/, $first_metric);
|
|
$the_length = length ($fields[0]);
|
|
}
|
|
my $spaces = $max_length_first_metric - $the_length;
|
|
my $pad = "";
|
|
for my $p (1 .. $spaces)
|
|
{
|
|
$pad .= " ";
|
|
}
|
|
$metric_values = $pad . $metric_values;
|
|
gp_message ("debugXL", $subr_name, "pad = $pad");
|
|
gp_message ("debugXL", $subr_name, "metric_values = $metric_values");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Since the instruction address variable may change and because we need the
|
|
# original address without html controls, we use a new variable for the
|
|
# (potentially) modified address.
|
|
#------------------------------------------------------------------------------
|
|
$hex_instr_address = $orig_hex_instr_address;
|
|
$add_new_line_before = $FALSE;
|
|
$add_new_line_after = $FALSE;
|
|
|
|
if ($src_line eq "?")
|
|
|
|
#------------------------------------------------------------------------------
|
|
# There is no source line number. Do not add a link.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$modified_line = $hot_line . ' ' . $metric_values . ' [' . $src_line . '] ';
|
|
gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line");
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# There is a source line number. Mark it as link.
|
|
#------------------------------------------------------------------------------
|
|
$src_line_ref = "[<a href='#line_".$src_line."'>".$src_line."</a>]";
|
|
gp_message ("debugXL", $subr_name, "src_line_ref = $src_line_ref");
|
|
gp_message ("debugXL", $subr_name, "hex_instr_address = $hex_instr_address");
|
|
|
|
$modified_line = $hot_line . ' ' . $metric_values . ' ' . $src_line_ref . ' ';
|
|
gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Mark control flow instructions. Several cases need to be distinguished.
|
|
#
|
|
# In all cases we give the instruction a specific color, mark it boldface
|
|
# and add a new-line after the instruction
|
|
#------------------------------------------------------------------------------
|
|
if ( ($instruction =~ /$control_flow_1_regex/) or
|
|
($instruction =~ /$control_flow_2_regex/) or
|
|
($instruction =~ /$control_flow_3_regex/) )
|
|
{
|
|
gp_message ("debugXL", $subr_name, "instruction = $instruction is a control flow instruction");
|
|
|
|
$add_new_line_after = $TRUE;
|
|
|
|
$boldface = $TRUE;
|
|
$instruction = color_string ($instruction, $boldface, $g_html_color_scheme{"control_flow"});
|
|
}
|
|
|
|
if (exists ($extended_branch_target{$hex_instr_address}))
|
|
#------------------------------------------------------------------------------
|
|
# This is a branch instruction and we need to add the target address.
|
|
#
|
|
# In case the target address is outside of this load object, the link is
|
|
# colored differently.
|
|
#
|
|
# TBD: Add the name and if possible, a working link to this code.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$branch_address = $extended_branch_target{$hex_instr_address};
|
|
|
|
$dec_branch_address = bigint::hex ($branch_address);
|
|
|
|
if ( ($dec_branch_address >= $dec_instruction_start) and
|
|
($dec_branch_address <= $dec_instruction_end) )
|
|
#------------------------------------------------------------------------------
|
|
# The instruction is within the range.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$link = "[ <a href='#".$branch_address."'>".$branch_address."</a> ]";
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The instruction is outside of the range. Change the color of the link.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "address is outside of range");
|
|
|
|
$link = "[ <a href='#".$branch_address;
|
|
$link .= "' style='color:$g_html_color_scheme{'link_outside_range'}'>";
|
|
$link .= $branch_address."</a> ]";
|
|
}
|
|
gp_message ("debugXL", $subr_name, "address exists new link = $link");
|
|
|
|
$operands .= ' ' . $link;
|
|
gp_message ("debugXL", $subr_name, "update #1 modified_line = $modified_line");
|
|
}
|
|
if (exists ($branch_target_no_ref{$hex_instr_address}))
|
|
{
|
|
gp_message ("debugXL", $subr_name, "NEWBR branch_target_no_ref{$hex_instr_address} = $branch_target_no_ref{$hex_instr_address}");
|
|
}
|
|
## if (exists ($inverse_branch_target{$hex_instr_address}) or
|
|
## exists ($branch_target_no_ref{$hex_instr_address}))
|
|
if (exists ($inverse_branch_target{$hex_instr_address}))
|
|
#------------------------------------------------------------------------------
|
|
# This is a target address and we need to define the instruction address to be
|
|
# a label.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$add_new_line_before = $TRUE;
|
|
|
|
my $branch_target = $inverse_branch_target{$hex_instr_address};
|
|
my $target = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>:";
|
|
gp_message ("debugXL", $subr_name, "inverse exists - hex_instr_address = $hex_instr_address");
|
|
gp_message ("debugXL", $subr_name, "inverse exists - add a target target = $target");
|
|
|
|
$hex_instr_address = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>";
|
|
gp_message ("debugXL", $subr_name, "update #2 hex_instr_address = $hex_instr_address");
|
|
gp_message ("debugXL", $subr_name, "update #2 modified_line = $modified_line");
|
|
}
|
|
|
|
$modified_line .= $hex_instr_address . ': ' . $instruction . ' ' . $operands;
|
|
|
|
gp_message ("debugXL", $subr_name, "final modified_line = $modified_line");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is a control flow instruction, but it is the last one and we do not
|
|
# want to add a newline.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "decide where the <br> should go in the html");
|
|
gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after");
|
|
gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before");
|
|
|
|
if ( $add_new_line_after and ($orig_hex_instr_address eq $hex_instruction_end) )
|
|
{
|
|
$add_new_line_after = $FALSE;
|
|
gp_message ("debugXL", $subr_name, "$instruction is the last instruction - do not add a newline");
|
|
}
|
|
|
|
if ($add_new_line_before)
|
|
{
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the previous line, if any, so that we can check what it is.
|
|
#------------------------------------------------------------------------------
|
|
my $prev_line = pop (@modified_html);
|
|
if ( defined ($prev_line) )
|
|
{
|
|
gp_message ("debugXL", $subr_name, "prev_line = $prev_line");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Restore the previously popped line.
|
|
#------------------------------------------------------------------------------
|
|
push (@modified_html, $prev_line);
|
|
if ($prev_line ne $html_new_line)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before pushed $html_new_line");
|
|
#------------------------------------------------------------------------------
|
|
# There is no new-line yet, so add it.
|
|
#------------------------------------------------------------------------------
|
|
push (@modified_html, $html_new_line);
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# It was a new-line, so do nothing and continue.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "need to restore $html_new_line");
|
|
}
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Add the newly created line.
|
|
#------------------------------------------------------------------------------
|
|
|
|
if ($hot_line eq "##")
|
|
#------------------------------------------------------------------------------
|
|
# Highlight the most expensive line.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$modified_line = set_background_color_string (
|
|
$modified_line,
|
|
$g_html_color_scheme{"background_color_hot"});
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Sub-highlight the lines close enough to the hot line.
|
|
#------------------------------------------------------------------------------
|
|
else
|
|
{
|
|
my @current_metrics = split (" ", $metric_values);
|
|
for my $metric (0 .. $#current_metrics)
|
|
{
|
|
my $current_value;
|
|
my $max_value;
|
|
$current_value = $current_metrics[$metric];
|
|
#------------------------------------------------------------------------------
|
|
# As part of the padding process, non-breaking spaces may have been inserted
|
|
# in an earlier phase. Temporarily remove these to make sure that the maximum
|
|
# metric values can be computed.
|
|
#------------------------------------------------------------------------------
|
|
$current_value =~ s/ //g;
|
|
if (exists ($max_metric_values[$metric]))
|
|
{
|
|
$max_value = $max_metric_values[$metric];
|
|
gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
|
|
if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) )
|
|
{
|
|
# TBD: abs needed?
|
|
gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
|
|
my $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value );
|
|
gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance");
|
|
if (($hp_value > 0) and ($relative_distance >= $hp_value/100.0))
|
|
{
|
|
gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance");
|
|
gp_message ("debugXL", $subr_name, "change bg modified_line = $modified_line");
|
|
$modified_line = set_background_color_string (
|
|
$modified_line,
|
|
$g_html_color_scheme{"background_color_lukewarm"});
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
## my @max_metric_values = ();
|
|
push (@modified_html, $modified_line);
|
|
if ($add_new_line_after)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after pushed $html_new_line");
|
|
push (@modified_html, $html_new_line);
|
|
}
|
|
|
|
}
|
|
else
|
|
{
|
|
my $msg = "parsing line $input_line";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
elsif ( $input_line =~ /$src_regex/ )
|
|
{
|
|
if ( defined ($1) and defined ($2) )
|
|
{
|
|
####### BUG?
|
|
gp_message ("debugXL", $subr_name, "found a source code line: $input_line");
|
|
gp_message ("debugXL", $subr_name, "\$1 = $1");
|
|
gp_message ("debugXL", $subr_name, "\$2 = $2");
|
|
gp_message ("debugXL", $subr_name, "\$3 = $3");
|
|
my $blanks = $1;
|
|
my $src_line = $2;
|
|
my $src_code = $3;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We need to replace the "<" symbol in the code by "<".
|
|
#------------------------------------------------------------------------------
|
|
$src_code =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
|
|
|
|
my $target = "<a name='line_".$src_line."'>".$src_line.".</a>";
|
|
gp_message ("debugXL", $subr_name, "src target = $target $src_code");
|
|
|
|
my $modified_line = $blanks . $target . $src_code;
|
|
gp_message ("debugXL", $subr_name, "modified_line = $modified_line");
|
|
push (@modified_html, $modified_line);
|
|
}
|
|
else
|
|
{
|
|
my $msg = "parsing line $input_line";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
elsif ( $input_line =~ /$function_regex/ )
|
|
{
|
|
my $html_name;
|
|
if (defined ($1) and defined ($2))
|
|
{
|
|
$func_name_in_dis_file = $2;
|
|
my $spaces = $1;
|
|
my $boldface = $TRUE;
|
|
gp_message ("debugXL", $subr_name, "function_name = $2");
|
|
my $function_line = "<Function: " . $func_name_in_dis_file . ">";
|
|
|
|
##### HACK
|
|
|
|
if ($func_name_in_dis_file eq $target_function)
|
|
{
|
|
my $color_function_name = color_string (
|
|
$function_line,
|
|
$boldface,
|
|
$g_html_color_scheme{"target_function_name"});
|
|
my $label = "<a id=\"" . $g_function_tag_id{$target_function} . "\"></a>";
|
|
$html_name = $label . $spaces . "<i>" . $color_function_name . "</i>";
|
|
}
|
|
else
|
|
{
|
|
my $color_function_name = color_string (
|
|
$function_line,
|
|
$boldface,
|
|
$g_html_color_scheme{"non_target_function_name"});
|
|
$html_name = "<i>" . $spaces . $color_function_name . "</i>";
|
|
}
|
|
push (@modified_html, $html_name);
|
|
}
|
|
else
|
|
{
|
|
my $msg = "parsing line $input_line";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add an extra line with diagnostics.
|
|
#
|
|
# TBD: The same is done in process_source but should be done only once.
|
|
#------------------------------------------------------------------------------
|
|
if ($hp_value > 0)
|
|
{
|
|
my $rounded_percentage = sprintf ("%.1f", $hp_value);
|
|
$threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>";
|
|
}
|
|
else
|
|
{
|
|
$threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>";
|
|
}
|
|
|
|
$html_home = ${ generate_home_link ("left") };
|
|
$html_end = ${ terminate_html_document () };
|
|
|
|
push (@modified_html, "</pre>");
|
|
push (@modified_html, $html_new_line);
|
|
push (@modified_html, $threshold_line);
|
|
push (@modified_html, $html_home);
|
|
push (@modified_html, $html_new_line);
|
|
push (@modified_html, $g_html_credits_line);
|
|
push (@modified_html, $html_end);
|
|
|
|
for my $i (0 .. $#modified_html)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]");
|
|
}
|
|
|
|
for my $i (0 .. $#modified_html)
|
|
{
|
|
print HTML_OUTPUT "$modified_html[$i]" . "\n";
|
|
}
|
|
|
|
close (HTML_OUTPUT);
|
|
close (INPUT_DISASSEMBLY);
|
|
|
|
gp_message ("debug", $subr_name, "output is in file $html_dis_out");
|
|
gp_message ("debug", $subr_name ,"completed processing disassembly");
|
|
|
|
undef %branch_target;
|
|
undef %extended_branch_target;
|
|
undef %inverse_branch_target;
|
|
|
|
return (\@source_line, \@metric);
|
|
|
|
} #-- End of subroutine generate_dis_html
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate all the function level information.
|
|
#------------------------------------------------------------------------------
|
|
sub generate_function_level_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string,
|
|
$sort_fields_ref) = @_;
|
|
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
my @sort_fields = @{ $sort_fields_ref };
|
|
|
|
my $expr_name;
|
|
my $first_metric;
|
|
my $gp_display_text_cmd;
|
|
my $gp_functions_cmd;
|
|
my $ignore_value;
|
|
my $script_pc_metrics;
|
|
|
|
my $outputdir = append_forward_slash ($input_string);
|
|
|
|
my $script_file_PC = $outputdir."gp-script-PC";
|
|
my $result_file = $outputdir."gp-out-PC.err";
|
|
my $gp_error_file = $outputdir."gp-out-PC.err";
|
|
my $func_limit = $g_user_settings{func_limit}{current_value};
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The number of entries in the Function Overview includes <Total>, but that is
|
|
# not a concern to the user and we add "1" to compensate for this.
|
|
#------------------------------------------------------------------------------
|
|
$func_limit += 1;
|
|
|
|
gp_message ("debug", $subr_name, "increased the local value for func_limit = $func_limit");
|
|
|
|
$expr_name = join (" ", @exp_dir_list);
|
|
|
|
gp_message ("debug", $subr_name, "expr_name = $expr_name");
|
|
|
|
for my $i (0 .. $#sort_fields)
|
|
{
|
|
gp_message ("debug", $subr_name, "sort_fields[$i] = $sort_fields[$i]");
|
|
}
|
|
|
|
# Ruud $count = 0;
|
|
|
|
gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files");
|
|
|
|
open (SCRIPT_PC, ">", $script_file_PC)
|
|
or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $script_file_PC for writing");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the list of functions.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the first metric.
|
|
#------------------------------------------------------------------------------
|
|
$summary_metrics =~ /^([^:]+)/;
|
|
$first_metric = $1;
|
|
$g_first_metric = $1;
|
|
$script_pc_metrics = "address:$summary_metrics";
|
|
|
|
gp_message ("debugXL", $subr_name, "$func_limit");
|
|
gp_message ("debugXL", $subr_name, "$summary_metrics");
|
|
gp_message ("debugXL", $subr_name, "$first_metric");
|
|
gp_message ("debugXL", $subr_name, "$script_pc_metrics");
|
|
|
|
# Temporarily disabled print SCRIPT_PC "# limit $func_limit\n";
|
|
# Temporarily disabled print SCRIPT_PC "limit $func_limit\n";
|
|
print SCRIPT_PC "# thread_select all\n";
|
|
print SCRIPT_PC "thread_select all\n";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Empty header.
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile $outputdir"."header\n";
|
|
print SCRIPT_PC "outfile $outputdir"."header\n";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Else the output from the next line goes to last sort.func
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n";
|
|
print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n";
|
|
print SCRIPT_PC "# metrics $script_pc_metrics\n";
|
|
print SCRIPT_PC "metrics $script_pc_metrics\n";
|
|
#------------------------------------------------------------------------------
|
|
# Not really sorted
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n";
|
|
print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n";
|
|
print SCRIPT_PC "# functions\n";
|
|
print SCRIPT_PC "functions\n";
|
|
|
|
print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n";
|
|
print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n";
|
|
print SCRIPT_PC "# metrics address:name:$summary_metrics\n";
|
|
print SCRIPT_PC "metrics address:name:$summary_metrics\n";
|
|
print SCRIPT_PC "# sort $first_metric\n";
|
|
print SCRIPT_PC "sort $first_metric\n";
|
|
print SCRIPT_PC "# functions\n";
|
|
print SCRIPT_PC "functions\n";
|
|
#------------------------------------------------------------------------------
|
|
# Go through all the possible metrics and sort by each of them.
|
|
#------------------------------------------------------------------------------
|
|
for my $field (@sort_fields)
|
|
{
|
|
gp_message ("debug", $subr_name, "sort_fields field = $field");
|
|
#------------------------------------------------------------------------------
|
|
# Else the output from the next line goes to last sort.func
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n";
|
|
print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n";
|
|
print SCRIPT_PC "# metrics $script_pc_metrics\n";
|
|
print SCRIPT_PC "metrics $script_pc_metrics\n";
|
|
print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC\n";
|
|
print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC\n";
|
|
print SCRIPT_PC "# sort $field\n";
|
|
print SCRIPT_PC "sort $field\n";
|
|
print SCRIPT_PC "# functions\n";
|
|
print SCRIPT_PC "functions\n";
|
|
|
|
print SCRIPT_PC "# metrics address:name:$summary_metrics\n";
|
|
print SCRIPT_PC "metrics address:name:$summary_metrics\n";
|
|
print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC2\n";
|
|
print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC2\n";
|
|
print SCRIPT_PC "# sort $field\n";
|
|
print SCRIPT_PC "sort $field\n";
|
|
print SCRIPT_PC "# functions\n";
|
|
print SCRIPT_PC "functions\n";
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get caller-callee list
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile " . $outputdir."caller-callee-PC2\n";
|
|
print SCRIPT_PC "outfile " . $outputdir."caller-callee-PC2\n";
|
|
print SCRIPT_PC "# metrics address:name:$summary_metrics\n";
|
|
print SCRIPT_PC "metrics address:name:$summary_metrics\n";
|
|
print SCRIPT_PC "# callers-callees\n";
|
|
print SCRIPT_PC "callers-callees\n";
|
|
#------------------------------------------------------------------------------
|
|
# Else the output from the next line goes to last sort.func
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n";
|
|
print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n";
|
|
$script_pc_metrics = "address:$call_metrics";
|
|
print SCRIPT_PC "# metrics $script_pc_metrics\n";
|
|
print SCRIPT_PC "metrics $script_pc_metrics\n";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Not really sorted
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n";
|
|
print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get caller-callee list
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# callers-callees\n";
|
|
print SCRIPT_PC "callers-callees\n";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Else the output from the next line goes to last sort.func
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calltree-PC\n";
|
|
print SCRIPT_PC "outfile $outputdir"."gp-metrics-calltree-PC\n";
|
|
print SCRIPT_PC "# metrics $script_pc_metrics\n";
|
|
print SCRIPT_PC "metrics $script_pc_metrics\n";
|
|
|
|
if ($g_user_settings{"calltree"}{"current_value"} eq "on")
|
|
{
|
|
gp_message ("verbose", $subr_name, "Generate the file with the calltree information");
|
|
#------------------------------------------------------------------------------
|
|
# Get calltree list
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# outfile $outputdir"."calltree.sort.func-PC\n";
|
|
print SCRIPT_PC "outfile $outputdir"."calltree.sort.func-PC\n";
|
|
print SCRIPT_PC "# calltree\n";
|
|
print SCRIPT_PC "calltree\n";
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the default set of metrics
|
|
#------------------------------------------------------------------------------
|
|
my $full_metrics_ref;
|
|
my $all_metrics;
|
|
my $full_function_view = $outputdir . "functions.full";
|
|
|
|
$full_metrics_ref = get_all_the_metrics (\$expr_name, \$outputdir);
|
|
|
|
$all_metrics = "address:name:";
|
|
$all_metrics .= ${$full_metrics_ref};
|
|
gp_message ("debug", $subr_name, "all_metrics = $all_metrics");
|
|
#------------------------------------------------------------------------------
|
|
# Get the name, address, and full overview of all metrics for all functions
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_PC "# limit 0\n";
|
|
print SCRIPT_PC "limit 0\n";
|
|
print SCRIPT_PC "# metrics $all_metrics\n";
|
|
print SCRIPT_PC "metrics $all_metrics\n";
|
|
print SCRIPT_PC "# thread_select all\n";
|
|
print SCRIPT_PC "thread_select all\n";
|
|
print SCRIPT_PC "# sort default\n";
|
|
print SCRIPT_PC "sort default\n";
|
|
print SCRIPT_PC "# outfile $full_function_view\n";
|
|
print SCRIPT_PC "outfile $full_function_view\n";
|
|
print SCRIPT_PC "# functions\n";
|
|
print SCRIPT_PC "functions\n";
|
|
|
|
close (SCRIPT_PC);
|
|
|
|
$result_file = $outputdir."gp-out-PC.err";
|
|
$gp_error_file = $outputdir.$g_gp_error_logfile;
|
|
|
|
$gp_functions_cmd = "$GP_DISPLAY_TEXT -limit $func_limit ";
|
|
$gp_functions_cmd .= "-viewmode machine -compare off ";
|
|
$gp_functions_cmd .= "-script $script_file_PC $expr_name";
|
|
|
|
gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function level information");
|
|
|
|
$gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file";
|
|
|
|
gp_message ("debugXL", $subr_name,"cmd = $gp_display_text_cmd");
|
|
|
|
my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
$ignore_value = msg_display_text_failure ($gp_display_text_cmd,
|
|
$error_code,
|
|
$gp_error_file);
|
|
gp_message ("abort", "execution terminated");
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Parse the full function view and store the data.
|
|
#-------------------------------------------------------------------------------
|
|
my @input_data = ();
|
|
my $empty_line_regex = '^\s*$';
|
|
|
|
## my $full_function_view = $outputdir . "functions.full";
|
|
|
|
open (ALL_FUNC_DATA, "<", $full_function_view)
|
|
or die ("$subr_name - unable to open output file $full_function_view for reading '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $full_function_view for reading");
|
|
|
|
chomp (@input_data = <ALL_FUNC_DATA>);
|
|
|
|
my $start_scanning = $FALSE;
|
|
for (my $line = 0; $line <= $#input_data; $line++)
|
|
{
|
|
my $input_line = $input_data[$line];
|
|
|
|
# if ($input_line =~ /^<Total>\s+.*/)
|
|
if ($input_line =~ /\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)/)
|
|
{
|
|
$start_scanning = $TRUE;
|
|
}
|
|
elsif ($input_line =~ /$empty_line_regex/)
|
|
{
|
|
$start_scanning = $FALSE;
|
|
}
|
|
|
|
if ($start_scanning)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "$line: $input_data[$line]");
|
|
|
|
push (@g_full_function_view_table, $input_data[$line]);
|
|
|
|
my $hex_address;
|
|
my $full_hex_address = $1;
|
|
my $routine = $2;
|
|
my $all_metrics = $3;
|
|
if ($full_hex_address =~ /(\d+):0x(\S+)/)
|
|
{
|
|
$hex_address = "0x" . $2;
|
|
}
|
|
$g_function_view_all{$routine}{"hex_address"} = $hex_address;
|
|
$g_function_view_all{$routine}{"all_metrics"} = $all_metrics;
|
|
}
|
|
}
|
|
|
|
for my $i (keys %g_function_view_all)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "key = $i $g_function_view_all{$i}{'hex_address'} $g_function_view_all{$i}{'all_metrics'}");
|
|
}
|
|
|
|
for my $i (keys @g_full_function_view_table)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "g_full_function_view_table[$i] = $i $g_full_function_view_table[$i]");
|
|
}
|
|
|
|
return ($script_pc_metrics);
|
|
|
|
} #-- End of subroutine generate_function_level_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate all the files needed for the function view.
|
|
#------------------------------------------------------------------------------
|
|
sub generate_function_view
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($directory_name_ref, $summary_metrics_ref, $number_of_metrics_ref,
|
|
$function_info_ref, $function_view_structure_ref, $function_address_info_ref,
|
|
$sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref) = @_;
|
|
|
|
my $directory_name = ${ $directory_name_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
my %function_view_structure = %{ $function_view_structure_ref };
|
|
my $summary_metrics = ${ $summary_metrics_ref };
|
|
my $number_of_metrics = ${ $number_of_metrics_ref };
|
|
my %function_address_info = %{ $function_address_info_ref };
|
|
my @sort_fields = @{ $sort_fields_ref };
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
my %addressobjtextm = %{ $addressobjtextm_ref };
|
|
|
|
my @abs_path_exp_dirs = ();
|
|
my @experiment_directories;
|
|
|
|
my $target_function;
|
|
my $html_line;
|
|
my $ftag;
|
|
my $routine_length;
|
|
my %html_source_functions = ();
|
|
|
|
my $href_link;
|
|
my $infile;
|
|
my $input_experiments;
|
|
my $keep_value;
|
|
my $loadobj;
|
|
my $address_field;
|
|
my $address_offset;
|
|
my $msg;
|
|
my $exe;
|
|
my $extra_field;
|
|
my $new_target_function;
|
|
my $file_title;
|
|
my $html_output_file;
|
|
my $html_function_view;
|
|
my $overview_file;
|
|
my $exp_name;
|
|
my $exp_type;
|
|
my $html_header;
|
|
my $routine;
|
|
my $length_header;
|
|
my $length_metrics;
|
|
my $full_index_line;
|
|
my $acknowledgement;
|
|
my @full_function_view_line = ();
|
|
my $spaces;
|
|
my $size_text;
|
|
my $position_text;
|
|
my $html_first_metric_file;
|
|
my $html_new_line = "<br>";
|
|
my $html_acknowledgement;
|
|
my $html_end;
|
|
my $html_home;
|
|
my $page_title;
|
|
my $html_title_header;
|
|
|
|
my $outputdir = append_forward_slash ($directory_name);
|
|
my $LANG = $g_locale_settings{"LANG"};
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
|
|
$input_experiments = join (", ", @exp_dir_list);
|
|
|
|
for my $i (0 .. $#exp_dir_list)
|
|
{
|
|
my $dir = get_basename ($exp_dir_list[$i]);
|
|
push @abs_path_exp_dirs, $dir;
|
|
}
|
|
$input_experiments = join (", ", @abs_path_exp_dirs);
|
|
|
|
gp_message ("debug", $subr_name, "input_experiments = $input_experiments");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: This should be done only once and much earlier.
|
|
#------------------------------------------------------------------------------
|
|
@experiment_directories = split (",", $input_experiments);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# For every function in the function overview, set up an html structure with
|
|
# the various hyperlinks.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Core loop that generates an HTML line for each function.
|
|
#------------------------------------------------------------------------------
|
|
my $top_of_table = $FALSE;
|
|
for my $i (0 .. $#function_info)
|
|
{
|
|
if (defined ($function_info[$i]{"alt_name"}))
|
|
{
|
|
$target_function = $function_info[$i]{"alt_name"};
|
|
}
|
|
else
|
|
{
|
|
my $msg = "function_info[$i]{\"alt_name\"} is not defined";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
$html_source_functions{$target_function} = $function_info[$i]{"html function block"};
|
|
}
|
|
|
|
for my $i (sort keys %html_source_functions)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}");
|
|
}
|
|
|
|
$file_title = "Function view for experiments " . $input_experiments;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Example input file:
|
|
|
|
# Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm
|
|
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
|
|
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
|
|
# Functions sorted by metric: Exclusive Total CPU Time
|
|
#
|
|
# PC Addr. Name Excl. Excl. CPU Excl. Excl.
|
|
# Total Cycles Instructions Last-Level
|
|
# CPU sec. sec. Executed Cache Misses
|
|
# 1:0x00000000 <Total> 3.502 4.005 15396819700 24024250
|
|
# 2:0x000021ae mxv_core 3.342 3.865 14500538981 23824045
|
|
# 6:0x0003af50 erand48_r 0.080 0.084 768240570 0
|
|
# 2:0x00001f7b init_data 0.040 0.028 64020043 200205
|
|
# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
|
|
# ...
|
|
#------------------------------------------------------------------------------
|
|
|
|
for my $metric (@sort_fields)
|
|
{
|
|
$overview_file = $outputdir . $metric . ".sort.func-PC2";
|
|
|
|
$exp_type = $metric;
|
|
|
|
if ($metric eq "functions")
|
|
{
|
|
$html_function_view .= $g_html_base_file_name{"function_view"} . ".html";
|
|
}
|
|
else
|
|
{
|
|
$html_function_view = $g_html_base_file_name{"function_view"} . "." . $metric . ".html";
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# The default function view is based upon the first metric in the list. We use
|
|
# this file in the index.html file.
|
|
#------------------------------------------------------------------------------
|
|
if ($metric eq $g_first_metric)
|
|
{
|
|
$html_first_metric_file = $html_function_view;
|
|
my $txt = "g_first_metric = $g_first_metric ";
|
|
$txt .= "html_first_metric_file = $html_first_metric_file";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
}
|
|
|
|
$html_output_file = $outputdir . $html_function_view;
|
|
|
|
open (FUNCTION_VIEW, ">", $html_output_file)
|
|
or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $html_output_file for writing");
|
|
|
|
$html_home = ${ generate_home_link ("right") };
|
|
$html_header = ${ create_html_header (\$file_title) };
|
|
|
|
$page_title = "Function View";
|
|
$size_text = "h2";
|
|
$position_text = "center";
|
|
$html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
|
|
|
|
print FUNCTION_VIEW $html_header;
|
|
print FUNCTION_VIEW $html_home;
|
|
print FUNCTION_VIEW $html_title_header;
|
|
print FUNCTION_VIEW "$_" for @g_html_experiment_stats;
|
|
print FUNCTION_VIEW $html_new_line . "\n";
|
|
|
|
my $function_view_structure_ref = process_function_overview (
|
|
\$metric,
|
|
\$exp_type,
|
|
\$summary_metrics,
|
|
\$number_of_metrics,
|
|
\@function_info,
|
|
\%function_view_structure,
|
|
\$overview_file);
|
|
|
|
my %function_view_structure = %{ $function_view_structure_ref };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Core part: extract the true function name and find the html code for it.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "the final table");
|
|
|
|
print FUNCTION_VIEW "<pre>\n";
|
|
print FUNCTION_VIEW "$_\n" for @{ $function_view_structure{"header"} };
|
|
|
|
my $max_length_header = $function_view_structure{"max header length"};
|
|
my $max_length_metrics = $function_view_structure{"max metrics length"};
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add 4 more spaces for the distance to the function names. Purely cosmetic.
|
|
#------------------------------------------------------------------------------
|
|
my $pad = max ($max_length_metrics, $max_length_header) + 4;
|
|
my $spaces = "";
|
|
for my $i (1 .. $pad)
|
|
{
|
|
$spaces .= " ";
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add extra space for the /blank/*/ marker!
|
|
#------------------------------------------------------------------------------
|
|
$spaces .= " ";
|
|
my $func_header = $spaces . $function_view_structure{"table name"};
|
|
gp_message ("debugXL", $subr_name, "func_header = " . $func_header);
|
|
|
|
|
|
print FUNCTION_VIEW $spaces . "<b>" .
|
|
$function_view_structure{"table name"} .
|
|
"</b>" . $html_new_line . "\n";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If the header is longer than the metrics, add spaces to padd the difference.
|
|
# Also add the same 4 spaces between the metric values and the function name.
|
|
#------------------------------------------------------------------------------
|
|
$pad = 0;
|
|
if ($max_length_header > $max_length_metrics)
|
|
{
|
|
$pad = $max_length_header - $max_length_metrics;
|
|
}
|
|
$pad += 4;
|
|
$spaces = "";
|
|
for my $i (1 .. $pad)
|
|
{
|
|
$spaces .= " ";
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is where it literally all comes together. The metrics and function
|
|
# parts are combined.
|
|
#------------------------------------------------------------------------------
|
|
## for my $i (keys @{ $function_view_structure{"function table"} })
|
|
for my $i (0 .. $#{ $function_view_structure{"function table"} })
|
|
{
|
|
my $p1 = $function_view_structure{"metrics part"}[$i];
|
|
my $p2 = $function_view_structure{"function table"}[$i];
|
|
|
|
$full_index_line = $p1 . $spaces . $p2;
|
|
|
|
push (@full_function_view_line, $full_index_line);
|
|
}
|
|
|
|
print FUNCTION_VIEW "$_\n" for @full_function_view_line;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Clear the array before filling it up again.
|
|
#-------------------------------------------------------------------------------
|
|
@full_function_view_line = ();
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Get the acknowledgement, return to main link, and final html statements.
|
|
#-------------------------------------------------------------------------------
|
|
$html_home = ${ generate_home_link ("left") };
|
|
$html_acknowledgement = ${ create_html_credits () };
|
|
$html_end = ${ terminate_html_document () };
|
|
|
|
print FUNCTION_VIEW "</pre>\n";
|
|
print FUNCTION_VIEW $html_home;
|
|
print FUNCTION_VIEW $html_new_line . "\n";
|
|
print FUNCTION_VIEW $html_acknowledgement;
|
|
print FUNCTION_VIEW $html_end;
|
|
|
|
close (FUNCTION_VIEW);
|
|
}
|
|
|
|
return (\$html_first_metric_file);
|
|
|
|
} #-- End of subroutine generate_function_view
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate an html line that links back to index.html. The text can either
|
|
# be positioned to the left or to the right.
|
|
#------------------------------------------------------------------------------
|
|
sub generate_home_link
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($which_side) = @_;
|
|
|
|
my $html_home_line;
|
|
|
|
if (($which_side ne "left") and ($which_side ne "right"))
|
|
{
|
|
my $msg = "which_side = $which_side not supported";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
$html_home_line .= "<div class=\"" . $which_side . "\">";
|
|
$html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"};
|
|
$html_home_line .= ".html' style='background-color:";
|
|
$html_home_line .= $g_html_color_scheme{"index"};
|
|
$html_home_line .= "'><b>Return to main view</b></a>";
|
|
$html_home_line .= "</div>";
|
|
|
|
return (\$html_home_line);
|
|
|
|
} #-- End of subroutine generate_home_link
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate a block of html for this function block.
|
|
#------------------------------------------------------------------------------
|
|
sub generate_html_function_blocks
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my (
|
|
$index_start_ref,
|
|
$index_end_ref,
|
|
$hex_addresses_ref,
|
|
$the_metrics_ref,
|
|
$length_first_metric_ref,
|
|
$special_marker_ref,
|
|
$the_function_name_ref,
|
|
$separator_ref,
|
|
$number_of_metrics_ref,
|
|
$data_function_block_ref,
|
|
$function_info_ref,
|
|
$function_view_structure_ref) = @_;
|
|
|
|
my $index_start = ${ $index_start_ref };
|
|
my $index_end = ${ $index_end_ref };
|
|
my @hex_addresses = @{ $hex_addresses_ref };
|
|
my @the_metrics = @{ $the_metrics_ref };
|
|
my @length_first_metric = @{ $length_first_metric_ref };
|
|
my @special_marker = @{ $special_marker_ref };
|
|
my @the_function_name = @{ $the_function_name_ref};
|
|
|
|
my $separator = ${ $separator_ref };
|
|
my $number_of_metrics = ${ $number_of_metrics_ref };
|
|
my $data_function_block = ${ $data_function_block_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
my %function_view_structure = %{ $function_view_structure_ref };
|
|
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
|
|
my @html_block_prologue = ();
|
|
my @html_code_function_block = ();
|
|
my @function_lines = ();
|
|
my @fields = ();
|
|
my @address_field = ();
|
|
my @metric_values = ();
|
|
my @function_names = ();
|
|
my @final_function_names = ();
|
|
my @marker = ();
|
|
my @split_number = ();
|
|
my @function_tags = ();
|
|
|
|
my $all_metrics;
|
|
my $current_function_name;
|
|
my $no_of_fields;
|
|
my $name_regex;
|
|
my $full_hex_address;
|
|
my $hex_address;
|
|
my $target_function;
|
|
my $marker_function;
|
|
my $routine;
|
|
my $routine_length;
|
|
my $metrics_length;
|
|
my $max_metrics_length = 0;
|
|
my $modified_line;
|
|
my $string_length;
|
|
my $addr_offset;
|
|
my $current_address;
|
|
my $found_a_match;
|
|
my $ref_index;
|
|
my $alt_name;
|
|
my $length_first_field;
|
|
my $gap;
|
|
my $ipad;
|
|
my $html_line;
|
|
my $target_tag;
|
|
my $tag_for_header;
|
|
my $href_file;
|
|
my $found_alt_name;
|
|
my $name_in_header;
|
|
my $create_hyperlinks;
|
|
|
|
state $first_call = $TRUE;
|
|
state $reference_length;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If the length of the first metric is less than the maximum over all first
|
|
# metrics, add spaces to the left to ensure correct alignment.
|
|
#------------------------------------------------------------------------------
|
|
for my $k ($index_start .. $index_end)
|
|
{
|
|
my $pad = $g_max_length_first_metric - $length_first_metric[$k];
|
|
if ($pad ge 1)
|
|
{
|
|
my $spaces = "";
|
|
for my $s (1 .. $pad)
|
|
{
|
|
$spaces .= " ";
|
|
}
|
|
$the_metrics[$k] = $spaces . $the_metrics[$k];
|
|
|
|
my $msg = "padding spaces = $spaces the_metrics[$k] = $the_metrics[$k]";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
|
|
## my $end_game = "end game3=> pad = $pad" . $hex_addresses[$k] . " " . $the_metrics[$k] . " " . $special_marker[$k] . $the_function_name[$k];
|
|
## gp_message ("debugXL", $subr_name, $end_game);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# An example what @function_lines should look like after the split:
|
|
# <empty>
|
|
# 6:0x0003ad20 drand48 0.100 0.084 768240570 0
|
|
# 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0
|
|
# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
|
|
#------------------------------------------------------------------------------
|
|
@function_lines = split ($separator, $data_function_block);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse the individual lines. Replace multi-occurrence functions by their
|
|
# unique alternative name and mark the target function.
|
|
#
|
|
# The above split operation produces an empty first field because the line
|
|
# starts with the separator. This is why skip the first field.
|
|
#------------------------------------------------------------------------------
|
|
for my $i ($index_start .. $index_end)
|
|
{
|
|
my $input_line = $the_metrics[$i];
|
|
|
|
gp_message ("debugXL", $subr_name, "the_metrics[$i] = ". $the_metrics[$i]);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# In case the last metric is 0. only, we append 3 extra characters that
|
|
# represent zero. We cannot change the number to 0.000 though because that
|
|
# has a different interpretation than 0.
|
|
# In a later phase, the "ZZZ" symbol will be removed again, but for now it
|
|
# creates consistency in, for example, the length of the metrics part.
|
|
#------------------------------------------------------------------------------
|
|
if ($input_line =~ /[\w0-9$decimal_separator]*(0$decimal_separator$)/)
|
|
{
|
|
if (defined ($1) )
|
|
{
|
|
my $decimal_point = $decimal_separator;
|
|
$decimal_point =~ s/\\//;
|
|
my $txt = "input_line = $input_line = ended with 0";
|
|
$txt .= $decimal_point;
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
|
|
$the_metrics[$i] .= "ZZZ";
|
|
}
|
|
}
|
|
|
|
$hex_address = $hex_addresses[$i];
|
|
$marker_function = $special_marker[$i];
|
|
$routine = $the_function_name[$i];
|
|
#------------------------------------------------------------------------------
|
|
# Get the length of the metrics line before ZZZ is replaced by spaces.
|
|
#------------------------------------------------------------------------------
|
|
$all_metrics = $the_metrics[$i];
|
|
$metrics_length = length ($all_metrics);
|
|
$all_metrics =~ s/ZZZ/ /g;
|
|
|
|
$max_metrics_length = max ($max_metrics_length, $metrics_length);
|
|
|
|
push (@marker, $marker_function);
|
|
push (@address_field, $hex_address);
|
|
push (@metric_values, $all_metrics);
|
|
push (@function_names, $routine);
|
|
|
|
my $index_into_function_info_ref = get_index_function_info (
|
|
\$routine,
|
|
\$hex_addresses[$i],
|
|
$function_info_ref);
|
|
|
|
my $index_into_function_info = ${ $index_into_function_info_ref };
|
|
$target_tag = $function_info[$index_into_function_info]{"tag_id"};
|
|
$alt_name = $function_info[$index_into_function_info]{"alt_name"};
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Keep the name of the target function (the one marked with a *) for later use.
|
|
# This is the tag that identifies the block in the caller-callee output. The
|
|
# tag is used in the link to the caller-callee in the function overview.
|
|
#------------------------------------------------------------------------------
|
|
if ($marker_function eq "*")
|
|
{
|
|
$tag_for_header = $target_tag;
|
|
$name_in_header = $alt_name;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We need to replace the "<" symbol in the code by "<".
|
|
#------------------------------------------------------------------------------
|
|
$name_in_header =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
|
|
|
|
}
|
|
push (@final_function_names, $alt_name);
|
|
push (@function_tags, $target_tag);
|
|
|
|
gp_message ("debugXL", $subr_name, "index_into_function_info = $index_into_function_info");
|
|
gp_message ("debugXL", $subr_name, "target_tag = $target_tag");
|
|
gp_message ("debugXL", $subr_name, "alt_name = $alt_name");
|
|
|
|
} #-- End of loop for my $i ($index_start .. $index_end)
|
|
|
|
my $tag_line = "<a id='" . $tag_for_header . "'></a>";
|
|
$html_line = "<br>\n";
|
|
$html_line .= $tag_line . "Function name: ";
|
|
$html_line .= "<span style='color:" . $g_html_color_scheme{"target_function_name"} . "'>";
|
|
$html_line .= "<b>" . $name_in_header . "</b></span>\n";
|
|
$html_line .= "<br>";
|
|
|
|
push (@html_block_prologue, $html_line);
|
|
|
|
gp_message ("debugXL", $subr_name, "the final function block for $name_in_header");
|
|
|
|
$href_file = $g_html_base_file_name{"caller_callee"} . ".html";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process the function blocks and generate the HTML structure for them.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (0 .. $#final_function_names)
|
|
{
|
|
$current_function_name = $final_function_names[$i];
|
|
gp_message ("debugXL", $subr_name, "current_function_name = $current_function_name");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Do not add hyperlinks for <Total>.
|
|
#------------------------------------------------------------------------------
|
|
if ($current_function_name eq "<Total>")
|
|
{
|
|
$create_hyperlinks = $FALSE;
|
|
}
|
|
else
|
|
{
|
|
$create_hyperlinks = $TRUE;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We need to replace the "<" symbol in the code by "<".
|
|
#------------------------------------------------------------------------------
|
|
$current_function_name =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
|
|
|
|
$html_line = $metric_values[$i] . " ";
|
|
|
|
if ($marker[$i] eq "*")
|
|
{
|
|
$current_function_name = "<b>" . $current_function_name . "</b>";
|
|
}
|
|
$html_line .= " <a href='" . $href_file . "#" . $function_tags[$i] . "'>" . $current_function_name . "</a>";
|
|
|
|
if ($marker[$i] eq "*")
|
|
{
|
|
$html_line = "<br>" . $html_line;
|
|
}
|
|
elsif (($marker[$i] ne "*") and ($i == 0))
|
|
{
|
|
$html_line = "<br>" . $html_line;
|
|
}
|
|
|
|
gp_message ("debugXL", $subr_name, "html_line = $html_line");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Find the index into "function_info" for this particular function.
|
|
#------------------------------------------------------------------------------
|
|
$routine = $function_names[$i];
|
|
$current_address = $address_field[$i];
|
|
|
|
my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info);
|
|
my $target_index = ${ $target_index_ref };
|
|
|
|
gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address target_index = $target_index");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD Do this once for each function and store the result. This is a saving
|
|
# because functions may and typically will appear more than once.
|
|
#------------------------------------------------------------------------------
|
|
my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"};
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add the links to the line. Make sure there is at least one space.
|
|
#------------------------------------------------------------------------------
|
|
my $spaces = " ";
|
|
for my $k (1 .. $spaces_left)
|
|
{
|
|
$spaces .= " ";
|
|
}
|
|
|
|
if ($create_hyperlinks)
|
|
{
|
|
$html_line .= $spaces;
|
|
$html_line .= $function_info[$target_index]{"href_source"};
|
|
$html_line .= " ";
|
|
$html_line .= $function_info[$target_index]{"href_disassembly"};
|
|
}
|
|
|
|
push (@html_code_function_block, $html_line);
|
|
}
|
|
|
|
for my $lines (0 .. $#html_code_function_block)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "final html block = " . $html_code_function_block[$lines]);
|
|
}
|
|
|
|
return (\@html_block_prologue, \@html_code_function_block);
|
|
|
|
} #-- End of subroutine generate_html_function_blocks
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the index.html file.
|
|
#------------------------------------------------------------------------------
|
|
sub generate_index
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref,
|
|
$number_of_metrics_ref, $function_info_ref, $function_address_info_ref,
|
|
$sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref,
|
|
$metric_description_reversed_ref, $number_of_warnings_ref,
|
|
$table_execution_stats_ref) = @_;
|
|
|
|
my $outputdir = ${ $outputdir_ref };
|
|
my $html_first_metric_file = ${ $html_first_metric_file_ref };
|
|
my $summary_metrics = ${ $summary_metrics_ref };
|
|
my $number_of_metrics = ${ $number_of_metrics_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
my %function_address_info = %{ $function_address_info_ref };
|
|
my @sort_fields = @{ $sort_fields_ref };
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
my %addressobjtextm = %{ $addressobjtextm_ref };
|
|
my %metric_description_reversed = %{ $metric_description_reversed_ref };
|
|
my $number_of_warnings = ${ $number_of_warnings_ref };
|
|
my @table_execution_stats = @{ $table_execution_stats_ref };
|
|
|
|
my @file_contents = ();
|
|
|
|
my $acknowledgement;
|
|
my @abs_path_exp_dirs = ();
|
|
my $input_experiments;
|
|
my $target_function;
|
|
my $html_line;
|
|
my $ftag;
|
|
my $max_length = 0;
|
|
my %html_source_functions = ();
|
|
my $html_header;
|
|
my @experiment_directories = ();
|
|
my $html_acknowledgement;
|
|
my $html_file_title;
|
|
my $html_output_file;
|
|
my $html_function_view;
|
|
my $html_caller_callee_view;
|
|
my $html_experiment_info;
|
|
my $html_warnings_page;
|
|
my $href_link;
|
|
my $file_title;
|
|
my $html_gprofng;
|
|
my $html_end;
|
|
my $max_length_metrics;
|
|
my $page_title;
|
|
my $size_text;
|
|
my $position_text;
|
|
|
|
my $ln;
|
|
my $base;
|
|
my $base_index_page;
|
|
my $infile;
|
|
my $outfile;
|
|
my $rec;
|
|
my $skip;
|
|
my $callsize;
|
|
my $dest;
|
|
my $final_string;
|
|
my @headers;
|
|
my $header;
|
|
my $sort_index;
|
|
my $pc_address;
|
|
my $anchor;
|
|
my $directory_name;
|
|
my $f2;
|
|
my $f3;
|
|
my $file;
|
|
my $sline;
|
|
my $src;
|
|
my $srcfile_name;
|
|
my $tmp1;
|
|
my $tmp2;
|
|
my $fullsize;
|
|
my $regf2;
|
|
my $trimsize;
|
|
my $EIL;
|
|
my $EEIL;
|
|
my $AOBJ;
|
|
my $RI;
|
|
my $HDR;
|
|
my $CALLER_CALLEE;
|
|
my $NAME;
|
|
my $SRC;
|
|
my $TRIMMED;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add a forward slash to make it easier when creating file names.
|
|
#------------------------------------------------------------------------------
|
|
$outputdir = append_forward_slash ($outputdir);
|
|
gp_message ("debug", $subr_name, "outputdir = $outputdir");
|
|
|
|
my $LANG = $g_locale_settings{"LANG"};
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
|
|
$input_experiments = join (", ", @exp_dir_list);
|
|
|
|
for my $i (0 .. $#exp_dir_list)
|
|
{
|
|
my $dir = get_basename ($exp_dir_list[$i]);
|
|
push @abs_path_exp_dirs, $dir;
|
|
}
|
|
$input_experiments = join (", ", @abs_path_exp_dirs);
|
|
|
|
gp_message ("debug", $subr_name, "input_experiments = $input_experiments");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Pass in the values for $expr_name and $cmd
|
|
#------------------------------------------------------------------------------
|
|
$html_file_title = "Main index page";
|
|
|
|
@experiment_directories = split (",", $input_experiments);
|
|
$html_acknowledgement = ${ create_html_credits () };
|
|
|
|
$html_end = ${ terminate_html_document () };
|
|
|
|
$html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html";
|
|
|
|
open (INDEX, ">", $html_output_file)
|
|
or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $html_output_file for writing");
|
|
|
|
$page_title = "GPROFNG Performance Analysis";
|
|
$size_text = "h1";
|
|
$position_text = "center";
|
|
$html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
|
|
|
|
$html_header = ${ create_html_header (\$html_file_title) };
|
|
|
|
print INDEX $html_header;
|
|
print INDEX $html_gprofng;
|
|
print INDEX "$_" for @g_html_experiment_stats;
|
|
print INDEX "$_" for @table_execution_stats;
|
|
|
|
$html_experiment_info = "<a href=\'";
|
|
$html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html";
|
|
$html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n";
|
|
|
|
$html_warnings_page = "<a href=\'";
|
|
$html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html";
|
|
$html_warnings_page .= "\'><h3>Warnings (" . $number_of_warnings . ")</h3></a>\n";
|
|
|
|
$html_function_view = "<a href=\'";
|
|
$html_function_view .= $html_first_metric_file;
|
|
$html_function_view .= "\'><h3>Function View</h3></a>\n";
|
|
|
|
$html_caller_callee_view = "<a href=\'";
|
|
$html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html";
|
|
$html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n";
|
|
|
|
print INDEX "<br>\n";
|
|
## print INDEX "<b>\n";
|
|
print INDEX $html_experiment_info;
|
|
print INDEX $html_warnings_page;;
|
|
## print INDEX "<br>\n";
|
|
## print INDEX "<br>\n";
|
|
print INDEX $html_function_view;
|
|
## print INDEX "<br>\n";
|
|
## print INDEX "<br>\n";
|
|
print INDEX $html_caller_callee_view;
|
|
## print INDEX "</b>\n";
|
|
## print INDEX "<br>\n";
|
|
## print INDEX "<br>\n";
|
|
|
|
print INDEX $html_acknowledgement;
|
|
print INDEX $html_end;
|
|
|
|
close (INDEX);
|
|
|
|
gp_message ("debug", $subr_name, "closed file $html_output_file");
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine generate_index
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get all the metrics available
|
|
#
|
|
# (gp-display-text) metric_list
|
|
# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name
|
|
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
|
|
# Available metrics:
|
|
# Exclusive Total CPU Time: e.%totalcpu
|
|
# Inclusive Total CPU Time: i.%totalcpu
|
|
# Exclusive CPU Cycles: e.+%cycles
|
|
# Inclusive CPU Cycles: i.+%cycles
|
|
# Exclusive Instructions Executed: e+%insts
|
|
# Inclusive Instructions Executed: i+%insts
|
|
# Exclusive Last-Level Cache Misses: e+%llm
|
|
# Inclusive Last-Level Cache Misses: i+%llm
|
|
# Exclusive Instructions Per Cycle: e+IPC
|
|
# Inclusive Instructions Per Cycle: i+IPC
|
|
# Exclusive Cycles Per Instruction: e+CPI
|
|
# Inclusive Cycles Per Instruction: i+CPI
|
|
# Size: size
|
|
# PC Address: address
|
|
# Name: name
|
|
#------------------------------------------------------------------------------
|
|
sub get_all_the_metrics
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($experiments_ref, $outputdir_ref) = @_;
|
|
|
|
my $experiments = ${ $experiments_ref };
|
|
my $outputdir = ${ $outputdir_ref };
|
|
|
|
my $ignore_value;
|
|
my $gp_functions_cmd;
|
|
my $gp_display_text_cmd;
|
|
|
|
my $metrics_output_file = $outputdir . "metrics-all";
|
|
my $result_file = $outputdir . $g_gp_output_file;
|
|
my $gp_error_file = $outputdir . $g_gp_error_logfile;
|
|
my $script_file_metrics = $outputdir . "script-metrics";
|
|
|
|
my @metrics_data = ();
|
|
|
|
open (SCRIPT_METRICS, ">", $script_file_metrics)
|
|
or die ("$subr_name - unable to open script file $script_file_metrics for writing: '$!'");
|
|
gp_message ("debug", $subr_name, "opened script file $script_file_metrics for writing");
|
|
|
|
print SCRIPT_METRICS "# outfile $metrics_output_file\n";
|
|
print SCRIPT_METRICS "outfile $metrics_output_file\n";
|
|
print SCRIPT_METRICS "# metric_list\n";
|
|
print SCRIPT_METRICS "metric_list\n";
|
|
|
|
close (SCRIPT_METRICS);
|
|
|
|
$gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file_metrics $experiments";
|
|
|
|
gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get all the metrics");
|
|
|
|
$gp_display_text_cmd = "$gp_functions_cmd 1>> $result_file 2>> $gp_error_file";
|
|
gp_message ("debug", $subr_name, "cmd = $gp_display_text_cmd");
|
|
|
|
my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
$ignore_value = msg_display_text_failure ($gp_display_text_cmd,
|
|
$error_code,
|
|
$gp_error_file);
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
|
|
open (METRICS_INFO, "<", $metrics_output_file)
|
|
or die ("$subr_name - unable to open file $metrics_output_file for reading '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $metrics_output_file for reading");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read the input file into memory.
|
|
#------------------------------------------------------------------------------
|
|
chomp (@metrics_data = <METRICS_INFO>);
|
|
gp_message ("debug", $subr_name, "read all contents of file $metrics_output_file into memory");
|
|
gp_message ("debug", $subr_name, "\$#metrics_data = $#metrics_data");
|
|
|
|
my $input_line;
|
|
my $ignore_lines_regex = '^(?:Current|Available|\s+Size:|\s+PC Address:|\s+Name:)';
|
|
my $split_line_regex = '(.*): (.*)';
|
|
my $empty_line_regex = '^\s*$';
|
|
my @metric_list_all = ();
|
|
for (my $line_no=0; $line_no <= $#metrics_data; $line_no++)
|
|
{
|
|
|
|
$input_line = $metrics_data[$line_no];
|
|
|
|
## if ( not (($input_line =~ /$ignore_lines_regex/ or ($input_line =~ /^\s*$/))))
|
|
if ( not ($input_line =~ /$ignore_lines_regex/) and not ($input_line =~ /$empty_line_regex/) )
|
|
{
|
|
if ($input_line =~ /$split_line_regex/)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Remove the percentages.
|
|
#------------------------------------------------------------------------------
|
|
my $metric_definition = $2;
|
|
$metric_definition =~ s/\%//g;
|
|
gp_message ("debug", $subr_name, "line_no = $line_no $metrics_data[$line_no] metric_definition = $metric_definition");
|
|
push (@metric_list_all, $metric_definition);
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "\@metric_list_all = @metric_list_all");
|
|
|
|
my $final_list = join (":", @metric_list_all);
|
|
gp_message ("debug", $subr_name, "final_list = $final_list");
|
|
|
|
close (METRICS_INFO);
|
|
|
|
return (\$final_list);
|
|
|
|
} #-- End of subroutine get_all_the_metrics
|
|
|
|
#------------------------------------------------------------------------------
|
|
# A simple function to return the basename using fileparse. To keep things
|
|
# simple, a suffixlist is not supported. In case this is needed, use the
|
|
# fileparse function directly.
|
|
#------------------------------------------------------------------------------
|
|
sub get_basename
|
|
{
|
|
my ($full_name) = @_;
|
|
|
|
my $ignore_value_1;
|
|
my $ignore_value_2;
|
|
my $basename_value;
|
|
|
|
($basename_value, $ignore_value_1, $ignore_value_2) = fileparse ($full_name);
|
|
|
|
return ($basename_value);
|
|
|
|
} #-- End of subroutine get_basename
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the details on the experiments and store these in a file. Each
|
|
# experiment has its own file. This makes the processing easier.
|
|
#------------------------------------------------------------------------------
|
|
sub get_experiment_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($outputdir_ref, $exp_dir_list_ref) = @_;
|
|
|
|
my $outputdir = ${ $outputdir_ref };
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
|
|
my $cmd_output;
|
|
my $current_slot;
|
|
my $error_code;
|
|
my $exp_info_file;
|
|
my @exp_info = ();
|
|
my @experiment_data = ();
|
|
my $gp_error_file;
|
|
my $gp_display_text_cmd;
|
|
my $gp_functions_cmd;
|
|
my $gp_log_file;
|
|
my $ignore_value;
|
|
my $overview_file;
|
|
my $result_file;
|
|
my $script_file;
|
|
my $the_experiments;
|
|
|
|
$the_experiments = join (" ", @exp_dir_list);
|
|
|
|
$script_file = $outputdir . "gp-info-exp.script";
|
|
$exp_info_file = $outputdir . "gp-info-exp-list.out";
|
|
$overview_file = $outputdir . "gp-overview.out";
|
|
$gp_log_file = $outputdir . $g_gp_output_file;
|
|
$gp_error_file = $outputdir . $g_gp_error_logfile;
|
|
|
|
open (SCRIPT_EXPERIMENT_INFO, ">", $script_file)
|
|
or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
|
|
gp_message ("debug", $subr_name, "opened script file $script_file for writing");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Attributed User CPU Time=a.user : for calltree - see P37 in manual
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT_EXPERIMENT_INFO "# compare on\n";
|
|
print SCRIPT_EXPERIMENT_INFO "compare on\n";
|
|
print SCRIPT_EXPERIMENT_INFO "# outfile $exp_info_file\n";
|
|
print SCRIPT_EXPERIMENT_INFO "outfile $exp_info_file\n";
|
|
print SCRIPT_EXPERIMENT_INFO "# exp_list\n";
|
|
print SCRIPT_EXPERIMENT_INFO "exp_list\n";
|
|
print SCRIPT_EXPERIMENT_INFO "# outfile $overview_file\n";
|
|
print SCRIPT_EXPERIMENT_INFO "outfile $overview_file\n";
|
|
print SCRIPT_EXPERIMENT_INFO "# overview\n";
|
|
print SCRIPT_EXPERIMENT_INFO "overview\n";
|
|
|
|
close SCRIPT_EXPERIMENT_INFO;
|
|
|
|
$gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments";
|
|
|
|
gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment information");
|
|
|
|
$gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file";
|
|
|
|
($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
$ignore_value = msg_display_text_failure ($gp_display_text_cmd,
|
|
$error_code,
|
|
$gp_error_file);
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# The first file has the following format:
|
|
#
|
|
# ID Sel PID Experiment
|
|
# == === ======= ======================================================
|
|
# 1 yes 2078714 <absolute_path/mxv.hwc.1.thr.er
|
|
# 2 yes 2078719 <absolute_path/mxv.hwc.2.thr.er
|
|
#-------------------------------------------------------------------------------
|
|
open (EXP_INFO, "<", $exp_info_file)
|
|
or die ("$subr_name - unable to open file $exp_info_file for reading '$!'");
|
|
gp_message ("debug", $subr_name, "opened script file $exp_info_file for reading");
|
|
|
|
chomp (@exp_info = <EXP_INFO>);
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# TBD - Check for the groups to exist below:
|
|
#-------------------------------------------------------------------------------
|
|
$current_slot = 0;
|
|
for my $i (0 .. $#exp_info)
|
|
{
|
|
my $input_line = $exp_info[$i];
|
|
|
|
gp_message ("debug", $subr_name, "$i => exp_info[$i] = $exp_info[$i]");
|
|
|
|
if ($input_line =~ /^\s*(\d+)\s+(.+)/)
|
|
{
|
|
my $exp_id = $1;
|
|
my $remainder = $2;
|
|
$experiment_data[$current_slot]{"exp_id"} = $exp_id;
|
|
$experiment_data[$current_slot]{"exp_data_file"} = $outputdir . "gp-info-exp-" . $exp_id . ".out";
|
|
gp_message ("debug", $subr_name, $i . " " . $exp_id . " " . $remainder);
|
|
if ($remainder =~ /^(\w+)\s+(\d+)\s+(.+)/)
|
|
{
|
|
my $exp_name = $3;
|
|
$experiment_data[$current_slot]{"exp_name_full"} = $exp_name;
|
|
$experiment_data[$current_slot]{"exp_name_short"} = get_basename ($exp_name);
|
|
$current_slot++;
|
|
gp_message ("debug", $subr_name, $i . " " . $1 . " " . $2 . " " . $3);
|
|
}
|
|
else
|
|
{
|
|
my $msg = "remainder = $remainder has an unexpected format";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
}
|
|
#-------------------------------------------------------------------------------
|
|
# The experiment IDs and names are known. We can now generate the info for
|
|
# each individual experiment.
|
|
#-------------------------------------------------------------------------------
|
|
$gp_log_file = $outputdir . $g_gp_output_file;
|
|
$gp_error_file = $outputdir . $g_gp_error_logfile;
|
|
|
|
$script_file = $outputdir . "gp-details-exp.script";
|
|
|
|
open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file)
|
|
or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
|
|
gp_message ("debug", $subr_name, "opened script file $script_file for writing");
|
|
|
|
for my $i (sort keys @experiment_data)
|
|
{
|
|
my $exp_id = $experiment_data[$i]{"exp_id"};
|
|
|
|
$result_file = $experiment_data[$i]{"exp_data_file"};
|
|
|
|
# statistics
|
|
# header
|
|
print SCRIPT_EXPERIMENT_DETAILS "# outfile " . $result_file . "\n";
|
|
print SCRIPT_EXPERIMENT_DETAILS "outfile " . $result_file . "\n";
|
|
print SCRIPT_EXPERIMENT_DETAILS "# header " . $exp_id . "\n";
|
|
print SCRIPT_EXPERIMENT_DETAILS "header " . $exp_id . "\n";
|
|
print SCRIPT_EXPERIMENT_DETAILS "# statistics " . $exp_id . "\n";
|
|
print SCRIPT_EXPERIMENT_DETAILS "statistics " . $exp_id . "\n";
|
|
|
|
}
|
|
|
|
close (SCRIPT_EXPERIMENT_DETAILS);
|
|
|
|
$gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments";
|
|
|
|
gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment details");
|
|
|
|
$gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file";
|
|
|
|
($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
|
|
|
|
if ($error_code != 0)
|
|
#-------------------------------------------------------------------------------
|
|
# This is unlikely to happen, but you never know.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
$ignore_value = msg_display_text_failure ($gp_display_text_cmd,
|
|
$error_code,
|
|
$gp_error_file);
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
|
|
return (\@experiment_data);
|
|
|
|
} #-- End of subroutine get_experiment_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This subroutine returns a string of the type "size=<n>", where <n> is the
|
|
# size of the file passed in. If n > 1024, a unit is appended.
|
|
#------------------------------------------------------------------------------
|
|
sub getfilesize
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($filename) = @_;
|
|
|
|
my $size;
|
|
my $file_stat;
|
|
|
|
if (not -e $filename)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The return value is used in the caller. This is why we return the empty
|
|
# string in case the file does not exist.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "filename = $filename not found");
|
|
return ("");
|
|
}
|
|
else
|
|
{
|
|
$file_stat = stat ($filename);
|
|
$size = $file_stat->size;
|
|
|
|
gp_message ("debug", $subr_name, "filename = $filename");
|
|
gp_message ("debug", $subr_name, "size = $size");
|
|
|
|
if ($size > 1024)
|
|
{
|
|
if ($size > 1024*1024)
|
|
{
|
|
$size = $size/1024/1024;
|
|
$size =~ s/\..*//;
|
|
$size = $size."MB";
|
|
}
|
|
else
|
|
{
|
|
$size = $size/1024;
|
|
$size =~ s/\..*//;
|
|
$size = $size."KB";
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$size=$size." bytes";
|
|
}
|
|
gp_message ("debug", $subr_name, "size = $size title=\"$size\"");
|
|
|
|
return ("title=\"$size\"");
|
|
}
|
|
|
|
} #-- End of subroutine getfilesize
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse the fsummary output and for all functions, store all the information
|
|
# found in "function_info". In addition to this, several derived structures
|
|
# are stored as well, making this structure a "onestop" place to get all the
|
|
# info that is needed.
|
|
#------------------------------------------------------------------------------
|
|
sub get_function_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($FSUMMARY_FILE) = @_;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The regex section.
|
|
#------------------------------------------------------------------------------
|
|
my $white_space_regex = '\s*';
|
|
|
|
my @function_info = ();
|
|
my %function_address_and_index = ();
|
|
my %LINUX_vDSO = ();
|
|
my %function_view_structure = ();
|
|
my %addressobjtextm = ();
|
|
#------------------------------------------------------------------------------
|
|
# TBD: This structure is no longer used and most likely can be removed.
|
|
#------------------------------------------------------------------------------
|
|
my %functions_index = ();
|
|
|
|
# TBD: check
|
|
my $full_address_field;
|
|
my %source_files = ();
|
|
|
|
my $i;
|
|
my $line;
|
|
my $routine_flag;
|
|
my $value;
|
|
my $whatever;
|
|
my $df_flag;
|
|
my $address_decimal;
|
|
my $routine;
|
|
|
|
my $num_source_files = 0;
|
|
my $number_of_functions = 0;
|
|
my $number_of_unique_functions = 0;
|
|
my $number_of_non_unique_functions = 0;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Open the file generated using the -fsummary option.
|
|
#------------------------------------------------------------------------------
|
|
open (FSUMMARY_FILE, "<", $FSUMMARY_FILE)
|
|
or die ("$subr_name - unable to open $FSUMMARY_FILE for reading: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $FSUMMARY_FILE for reading");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is the typical structure of the fsummary output:
|
|
#
|
|
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
|
|
# Functions sorted by metric: Exclusive Total CPU Time
|
|
#
|
|
# <Total>
|
|
# Exclusive Total CPU Time: 11.538 (100.0%)
|
|
# Inclusive Total CPU Time: 11.538 (100.0%)
|
|
# Size: 0
|
|
# PC Address: 1:0x00000000
|
|
# Source File: (unknown)
|
|
# Object File: (unknown)
|
|
# Load Object: <Total>
|
|
# Mangled Name:
|
|
# Aliases:
|
|
#
|
|
# a_function_name
|
|
# Exclusive Total CPU Time: 4.003 ( 34.7%)
|
|
# Inclusive Total CPU Time: 4.003 ( 34.7%)
|
|
# Size: 715
|
|
# PC Address: 2:0x00006c61
|
|
# Source File: <absolute path to source file>
|
|
# Object File: <object filename>
|
|
# Load Object: <executable name>
|
|
# Mangled Name:
|
|
# Aliases:
|
|
#
|
|
# The previous block is repeated for every function.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Skip the header. The header is defined to end with a blank line.
|
|
#------------------------------------------------------------------------------
|
|
while (<FSUMMARY_FILE>)
|
|
{
|
|
$line = $_;
|
|
chomp ($line);
|
|
if ($line =~ /^\s*$/)
|
|
{
|
|
last;
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process the remaining blocks. Note that the first line should be <Total>,
|
|
# but this is currently not checked.
|
|
#------------------------------------------------------------------------------
|
|
$i = 0;
|
|
$routine_flag = $TRUE;
|
|
while (<FSUMMARY_FILE>)
|
|
{
|
|
$line = $_;
|
|
chomp ($line);
|
|
gp_message ("debugXL", $subr_name, "line = $line");
|
|
|
|
if ($line =~ /^\s*$/)
|
|
#------------------------------------------------------------------------------
|
|
# Blank line.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$routine_flag = $TRUE;
|
|
$df_flag = 0;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Linux vDSO exception
|
|
#
|
|
# TBD: Check if still relevant.
|
|
#------------------------------------------------------------------------------
|
|
if ($function_info[$i]{"Load Object"} eq "DYNAMIC_FUNCTIONS")
|
|
{
|
|
$LINUX_vDSO{substr ($function_info[$i]{"addressobjtext"},1)} = $function_info[$i]{"routine"};
|
|
}
|
|
$i++;
|
|
next;
|
|
}
|
|
|
|
if ($routine_flag)
|
|
#------------------------------------------------------------------------------
|
|
# Should be the first line after the blank line.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$routine = $line;
|
|
push (@{ $g_map_function_to_index{$routine} }, $i);
|
|
gp_message ("debugXL", $subr_name, "pushed i = $i to g_map_function_to_index{$routine}");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# In a later parsing phase we need to know how many fields there are in a
|
|
# function name. For example, "<static>@0x21850 (<libc-2.28.so>)" is name that
|
|
# may show up in a function list.
|
|
#
|
|
# Here we determine the number of fields and store it.
|
|
#------------------------------------------------------------------------------
|
|
my @fields_in_name = split (" ", $routine);
|
|
$function_info[$i]{"fields in routine name"} = scalar (@fields_in_name);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This name may change if the function has multiple occurrences, but in any
|
|
# case, at the end of this routine this component has the final name to be
|
|
# used.
|
|
#------------------------------------------------------------------------------
|
|
$function_info[$i]{"alt_name"} = $routine;
|
|
if (not exists ($g_function_occurrences{$routine}))
|
|
{
|
|
gp_message ("debugXL", $subr_name, "the entry in function_info for $routine does not exist");
|
|
$function_info[$i]{"routine"} = $routine;
|
|
$g_function_occurrences{$routine} = 1;
|
|
|
|
gp_message ("debugXL", $subr_name, "g_function_occurrences{$routine} = $g_function_occurrences{$routine}");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debugXL", $subr_name, "the entry in function_info for $routine exists already");
|
|
$function_info[$i]{"routine"} = $routine;
|
|
$g_function_occurrences{$routine} += 1;
|
|
if (not exists ($g_multi_count_function{$routine}))
|
|
{
|
|
$g_multi_count_function{$routine} = $TRUE;
|
|
}
|
|
my $msg = "g_function_occurrences{$routine} = " .
|
|
$g_function_occurrences{$routine};
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# New: used when generating the index.
|
|
#------------------------------------------------------------------------------
|
|
$function_info[$i]{"function length"} = length ($routine);
|
|
$function_info[$i]{"tag_id"} = create_function_tag ($i);
|
|
if (not exists ($g_function_tag_id{$routine}))
|
|
{
|
|
$g_function_tag_id{$routine} = create_function_tag ($i);
|
|
}
|
|
else
|
|
{
|
|
|
|
#------------------------------------------------------------------------------
|
|
## TBD HACK!!! CHECK!!!!!
|
|
#------------------------------------------------------------------------------
|
|
$g_function_tag_id{$routine} = $i;
|
|
}
|
|
|
|
$routine_flag = $FALSE;
|
|
gp_message ("debugXL", $subr_name, "stored " . $function_info[$i]{"routine"});
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The $functions_index hash contains an array. After an initial assignment,
|
|
# other values that have been found are pushed onto the arrays.
|
|
#------------------------------------------------------------------------------
|
|
if (not exists ($functions_index{$routine}))
|
|
{
|
|
$functions_index{$routine} = [$i];
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Add the array index to the list
|
|
#------------------------------------------------------------------------------
|
|
push (@{$functions_index{$routine}}, $i);
|
|
}
|
|
next;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Expected format of an input line:
|
|
# Exclusive Total CPU Time: 4.003 ( 34.7%)
|
|
# or:
|
|
# Source File: <absolute_path>/name_of_source_file
|
|
#------------------------------------------------------------------------------
|
|
$line =~ s/^\s+//;
|
|
|
|
my @input_fields = split (":", $line);
|
|
my $no_of_elements = scalar (@input_fields);
|
|
|
|
gp_message ("debugXL", $subr_name, "#input_fields = $#input_fields");
|
|
gp_message ("debugXL", $subr_name, "no_of_elements = $no_of_elements");
|
|
gp_message ("debugXL", $subr_name, "input_fields[0] = $input_fields[0]");
|
|
|
|
if ($no_of_elements == 1)
|
|
{
|
|
$whatever = $input_fields[0];
|
|
$value = "";
|
|
}
|
|
elsif ($no_of_elements == 2)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Note that value may consist of multiple fields (e.g. 1.651 ( 95.4%)).
|
|
#------------------------------------------------------------------------------
|
|
$whatever = $input_fields[0];
|
|
$value = $input_fields[1];
|
|
}
|
|
elsif ($no_of_elements == 3)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Assumption: must be an address field. Restore the second colon.
|
|
#------------------------------------------------------------------------------
|
|
$whatever = $input_fields[0];
|
|
$value = $input_fields[1] . ":" . $input_fields[2];
|
|
}
|
|
else
|
|
{
|
|
my $msg = "unexpected: number of fields = " . $no_of_elements;
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Remove any leading whitespace characters.
|
|
#------------------------------------------------------------------------------
|
|
$value =~ s/$white_space_regex//;
|
|
|
|
gp_message ("debugXL", $subr_name, "whatever = $whatever value = $value");
|
|
|
|
$function_info[$i]{$whatever} = $value;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Seems to be not used anymore and can most likely be removed. Check this.
|
|
#------------------------------------------------------------------------------
|
|
if ($whatever =~ /Source File/)
|
|
{
|
|
if (!exists ($source_files{$value}))
|
|
{
|
|
$source_files{$value} = $TRUE;
|
|
$num_source_files++;
|
|
}
|
|
}
|
|
|
|
if ($whatever =~ /PC Address/)
|
|
{
|
|
my $segment;
|
|
my $offset;
|
|
#------------------------------------------------------------------------------
|
|
# The format of the address is assumed to be the following 2:0x000070a8
|
|
# Note that the regex is pretty wide. This is from the original code and
|
|
# could be made more specific:
|
|
# if ($value =~ /\s*(\S+):(\S+)/)
|
|
#------------------------------------------------------------------------------
|
|
# if ($value =~ /\s*(\S+):(\S+)/)
|
|
if ($value =~ /\s*(\d+):0x([0-9a-zA-Z]+)/)
|
|
{
|
|
$segment = $1;
|
|
$offset = $2;
|
|
#------------------------------------------------------------------------------
|
|
# Convert to a base 10 number
|
|
#------------------------------------------------------------------------------
|
|
$address_decimal = bigint::hex ($offset); # decimal
|
|
#------------------------------------------------------------------------------
|
|
# Construct the address field. Note that we use the hex address here.
|
|
#------------------------------------------------------------------------------
|
|
$full_address_field = '@'.$segment.":0x".$offset; # e.g. @2:0x0003f280
|
|
|
|
$function_info[$i]{"addressobj"} = $address_decimal;
|
|
$function_info[$i]{"addressobjtext"} = $full_address_field;
|
|
$addressobjtextm{$full_address_field} = $i; # $RI
|
|
}
|
|
if (not exists ($function_address_and_index{$routine}{$value}))
|
|
{
|
|
$function_address_and_index{$routine}{$value} = $i;
|
|
|
|
my $msg = "function_address_and_index{$routine}{$value} = " .
|
|
$function_address_and_index{$routine}{$value};
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debugXL", $subr_name, "function_info: $FSUMMARY_FILE: function $routine already has a PC Address");
|
|
}
|
|
|
|
$number_of_functions++;
|
|
}
|
|
}
|
|
close (FSUMMARY_FILE);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# For every function in the function overview, set up an html structure with
|
|
# the various hyperlinks.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "augment function_info with alt_name");
|
|
my $target_function;
|
|
my $html_line;
|
|
my $ftag;
|
|
my $routine_length;
|
|
my %html_source_functions = ();
|
|
for my $i (keys @function_info)
|
|
{
|
|
$target_function = $function_info[$i]{"routine"};
|
|
|
|
gp_message ("debugXL", $subr_name, "i = $i target_function = $target_function");
|
|
|
|
my $href_link;
|
|
## $href_link = "<a href=\'file." . $i . ".src.new.html#";
|
|
$href_link = "<a href=\'file." . $i . ".";
|
|
$href_link .= $g_html_base_file_name{"source"};
|
|
$href_link .= ".html#";
|
|
$href_link .= $function_info[$i]{"tag_id"};
|
|
$href_link .= "\'>source</a>";
|
|
$function_info[$i]{"href_source"} = $href_link;
|
|
|
|
$href_link = "<a href=\'file." . $i . ".";
|
|
$href_link .= $g_html_base_file_name{"disassembly"};
|
|
$href_link .= ".html#";
|
|
$href_link .= $function_info[$i]{"tag_id"};
|
|
$href_link .= "\'>disassembly</a>";
|
|
$function_info[$i]{"href_disassembly"} = $href_link;
|
|
|
|
$href_link = "<a href=\'";
|
|
$href_link .= $g_html_base_file_name{"caller_callee"};
|
|
$href_link .= ".html#";
|
|
$href_link .= $function_info[$i]{"tag_id"};
|
|
$href_link .= "\'>caller-callee</a>";
|
|
$function_info[$i]{"href_caller_callee"} = $href_link;
|
|
|
|
gp_message ("debug", $subr_name, "g_function_occurrences{$target_function} = $g_function_occurrences{$target_function}");
|
|
|
|
if ($g_function_occurrences{$target_function} > 1)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# In case a function occurs more than one time in the function overview, we
|
|
# add the load object and address offset info to make it unique.
|
|
#
|
|
# This forces us to update some entries in function_info too.
|
|
#------------------------------------------------------------------------------
|
|
my $loadobj = $function_info[$i]{"Load Object"};
|
|
my $address_field = $function_info[$i]{"addressobjtext"};
|
|
my $address_offset;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The address field has the following format: @<n>:<address_offset>
|
|
# We only care about the address offset.
|
|
#------------------------------------------------------------------------------
|
|
if ($address_field =~ /(^@\d*:*)(.+)/)
|
|
{
|
|
$address_offset = $2;
|
|
}
|
|
else
|
|
{
|
|
my $msg = "failed to extract the address offset from $address_field - use the full field";
|
|
gp_message ("warning", $subr_name, $msg);
|
|
$address_offset = $address_field;
|
|
}
|
|
my $exe = get_basename ($loadobj);
|
|
my $extra_field = " (<" . $exe . " $address_offset" .">)";
|
|
### $target_function .= $extra_field;
|
|
$function_info[$i]{"alt_name"} = $target_function . $extra_field;
|
|
gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"});
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Store the length of the function name and get the tag id.
|
|
#------------------------------------------------------------------------------
|
|
$function_info[$i]{"function length"} = length ($target_function . $extra_field);
|
|
$function_info[$i]{"tag_id"} = create_function_tag ($i);
|
|
|
|
gp_message ("debugXL", $subr_name, "updated function_info[$i]{'routine'} = $function_info[$i]{'routine'}");
|
|
gp_message ("debugXL", $subr_name, "updated function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}");
|
|
gp_message ("debugXL", $subr_name, "updated function_info[$i]{'function length'} = $function_info[$i]{'function length'}");
|
|
gp_message ("debugXL", $subr_name, "updated function_info[$i]{'tag_id'} = $function_info[$i]{'tag_id'}");
|
|
}
|
|
}
|
|
gp_message ("debug", $subr_name, "augment function_info with alt_name completed");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Compute the maximum function name length.
|
|
#
|
|
# The maximum length is stored in %function_view_structure.
|
|
#------------------------------------------------------------------------------
|
|
my $max_function_length = 0;
|
|
for my $i (0 .. $#function_info)
|
|
{
|
|
$max_function_length = max ($max_function_length, $function_info[$i]{"function length"});
|
|
|
|
gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"});
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Define the name of the table and take the length into account, since it may
|
|
# be longer than the function name(s).
|
|
#------------------------------------------------------------------------------
|
|
$function_view_structure{"table name"} = "Function name";
|
|
|
|
$max_function_length = max ($max_function_length, length ($function_view_structure{"table name"}));
|
|
|
|
$function_view_structure{"max function length"} = $max_function_length;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Core loop that generates an HTML line for each function. This line is
|
|
# stored in function_info.
|
|
#------------------------------------------------------------------------------
|
|
my $top_of_table = $FALSE;
|
|
for my $i (keys @function_info)
|
|
{
|
|
my $new_target_function;
|
|
|
|
if (defined ($function_info[$i]{"alt_name"}))
|
|
{
|
|
$target_function = $function_info[$i]{"alt_name"};
|
|
gp_message ("debugXL", $subr_name, "retrieved function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}");
|
|
}
|
|
else
|
|
{
|
|
my $msg = "function_info[$i]{\"alt_name\"} is not defined";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
my $function_length = $function_info[$i]{"function length"};
|
|
my $number_of_blanks = $function_view_structure{"max function length"} - $function_length;
|
|
|
|
my $spaces = " ";
|
|
for my $i (1 .. $number_of_blanks)
|
|
{
|
|
$spaces .= " ";
|
|
}
|
|
if ($target_function eq "<Total>")
|
|
#------------------------------------------------------------------------------
|
|
# <Total> is a pseudo function and there is no source, or disassembly for it.
|
|
# We could add a link to the caller-callee part, but this is currently not
|
|
# done.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$top_of_table = $TRUE;
|
|
$html_line = " <b><Total></b>";
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Add the * symbol as a marker in case the same function occurs multiple times.
|
|
# Otherwise insert a space.
|
|
#------------------------------------------------------------------------------
|
|
my $base_function_name = $function_info[$i]{"routine"};
|
|
if (exists ($g_function_occurrences{$base_function_name}))
|
|
{
|
|
if ($g_function_occurrences{$base_function_name} > 1)
|
|
{
|
|
$new_target_function = "*" . $target_function;
|
|
}
|
|
else
|
|
{
|
|
$new_target_function = " " . $target_function;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "g_function_occurrences{$base_function_name} does not exist";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Create the block with the function name, in boldface, plus the links to the
|
|
# source, disassembly and caller-callee views.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We need to replace the "<" symbol in the code by "<".
|
|
#------------------------------------------------------------------------------
|
|
$new_target_function =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
|
|
|
|
$html_line = "<b>$new_target_function</b>" . $spaces;
|
|
$html_line .= $function_info[$i]{"href_source"} . " ";
|
|
$html_line .= $function_info[$i]{"href_disassembly"} . " ";
|
|
$html_line .= $function_info[$i]{"href_caller_callee"};
|
|
}
|
|
|
|
gp_message ("debugXL", $subr_name, "target_function = $target_function html_line = $html_line");
|
|
$html_source_functions{$target_function} = $html_line;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: In the future we want to re-use this block elsewhere.
|
|
#------------------------------------------------------------------------------
|
|
$function_info[$i]{"html function block"} = $html_line;
|
|
}
|
|
|
|
for my $i (keys %html_source_functions)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}");
|
|
}
|
|
for my $i (keys @function_info)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "function_info[$i]{\"html function block\"} = " . $function_info[$i]{"html function block"});
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the key data structure %function_info. This is a nested hash.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (0 .. $#function_info)
|
|
{
|
|
for my $role (sort keys %{ $function_info[$i] })
|
|
{
|
|
gp_message ("debug", $subr_name, "on return: function_info[$i]{$role} = $function_info[$i]{$role}");
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Print the data structure %function_address_and_index. This is a nested hash.
|
|
#------------------------------------------------------------------------------
|
|
for my $F (keys %function_address_and_index)
|
|
{
|
|
for my $fields (sort keys %{ $function_address_and_index{$F} })
|
|
{
|
|
gp_message ("debug", $subr_name, "on return: function_address_and_index{$F}{$fields} = $function_address_and_index{$F}{$fields}");
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Print the data structure %functions_index. This is a hash with an arrray.
|
|
#------------------------------------------------------------------------------
|
|
for my $F (keys %functions_index)
|
|
{
|
|
gp_message ("debug", $subr_name, "on return: functions_index{$F} = @{ $functions_index{$F} }");
|
|
# alt code for my $i (0 .. $#{ $functions_index{$F} } )
|
|
# alt code {
|
|
# alt code gp_message ("debug", $subr_name, "on return: \$functions_index{$F} = $functions_index{$F}[$i]");
|
|
# alt code }
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the data structure %function_view_structure. This is a hash.
|
|
#------------------------------------------------------------------------------
|
|
for my $F (keys %function_view_structure)
|
|
{
|
|
gp_message ("debug", $subr_name, "on return: function_view_structure{$F} = $function_view_structure{$F}");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the data structure %g_function_occurrences and use this structure to
|
|
# gather statistics about the functions.
|
|
#
|
|
# TBD: add this info to the experiment data overview.
|
|
#------------------------------------------------------------------------------
|
|
$number_of_unique_functions = 0;
|
|
$number_of_non_unique_functions = 0;
|
|
for my $F (keys %g_function_occurrences)
|
|
{
|
|
gp_message ("debug", $subr_name, "on return: g_function_occurrences{$F} = $g_function_occurrences{$F}");
|
|
if ($g_function_occurrences{$F} == 1)
|
|
{
|
|
$number_of_unique_functions++;
|
|
}
|
|
else
|
|
{
|
|
$number_of_non_unique_functions++;
|
|
}
|
|
}
|
|
|
|
for my $i (keys %g_map_function_to_index)
|
|
{
|
|
my $n = scalar (@{ $g_map_function_to_index{$i} });
|
|
gp_message ("debug", $subr_name, "on return: g_map_function_to_index [$n] : $i => @{ $g_map_function_to_index{$i} }");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Include in experiment data. Include names with multiple occurrences.
|
|
#------------------------------------------------------------------------------
|
|
my $msg;
|
|
|
|
$msg = "Number of source files : " .
|
|
$num_source_files;
|
|
gp_message ("debug", $subr_name, $msg);
|
|
$msg = "Total number of functions: $number_of_functions";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
$msg = "Number of functions functions with a unique name : " .
|
|
$number_of_unique_functions;
|
|
gp_message ("debug", $subr_name, $msg);
|
|
$msg = "Number of functions functions with more than one occurrence : " .
|
|
$number_of_non_unique_functions;
|
|
gp_message ("debug", $subr_name, $msg);
|
|
my $multi_occurrences = $number_of_functions - $number_of_unique_functions;
|
|
$msg = "Total number of multiple occurences of the same function name : " .
|
|
$multi_occurrences;
|
|
gp_message ("debug", $subr_name, $msg);
|
|
|
|
return (\@function_info, \%function_address_and_index, \%addressobjtextm,
|
|
\%LINUX_vDSO, \%function_view_structure);
|
|
|
|
} #-- End of subroutine get_function_info
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub get_hdr_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($outputdir, $file) = @_;
|
|
|
|
state $first_call = $TRUE;
|
|
|
|
my $ASORTFILE;
|
|
my @HDR;
|
|
my $HDR;
|
|
my $metric;
|
|
my $line;
|
|
my $ignore_directory;
|
|
my $ignore_suffix;
|
|
my $number_of_header_lines;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add a "/" to simplify the construction of path names in the remainder.
|
|
#------------------------------------------------------------------------------
|
|
$outputdir = append_forward_slash ($outputdir);
|
|
|
|
# Could get more header info from
|
|
# <metric>[e.bit_fcount].sort.func file - etc.
|
|
|
|
gp_message ("debug", $subr_name, "input file->$file<-");
|
|
#-----------------------------------------------
|
|
if ($file eq $outputdir."calls.sort.func")
|
|
{
|
|
$ASORTFILE=$outputdir."calls";
|
|
$metric = "calls"
|
|
}
|
|
elsif ($file eq $outputdir."calltree.sort.func")
|
|
{
|
|
$ASORTFILE=$outputdir."calltree";
|
|
$metric = "calltree"
|
|
}
|
|
elsif ($file eq $outputdir."functions.sort.func")
|
|
{
|
|
$ASORTFILE=$outputdir."functions.func";
|
|
$metric = "functions";
|
|
}
|
|
else
|
|
{
|
|
$ASORTFILE = $file;
|
|
# $metric = basename ($file,".sort.func");
|
|
($metric, $ignore_directory, $ignore_suffix) = fileparse ($file, ".sort.func");
|
|
gp_message ("debug", $subr_name, "ignore_directory = $ignore_directory ignore_suffix = $ignore_suffix");
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "file = $file metric = $metric");
|
|
|
|
open (ASORTFILE,"<", $ASORTFILE)
|
|
or die ("$subr_name - unable to open file $ASORTFILE for reading: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $ASORTFILE for reading");
|
|
|
|
$number_of_header_lines = 0;
|
|
while (<ASORTFILE>)
|
|
{
|
|
$line =$_;
|
|
chomp ($line);
|
|
|
|
if ($line =~ /^Current/)
|
|
{
|
|
next;
|
|
}
|
|
if ($line =~ /^Functions/)
|
|
{
|
|
next;
|
|
}
|
|
if ($line =~ /^Callers/)
|
|
{
|
|
next;
|
|
}
|
|
if ($line =~ /^\s*$/)
|
|
{
|
|
next;
|
|
}
|
|
if (!($line =~ /^\s*\d/))
|
|
{
|
|
$HDR[$number_of_header_lines] = $line;
|
|
$number_of_header_lines++;
|
|
next;
|
|
}
|
|
last;
|
|
}
|
|
close (ASORTFILE);
|
|
#-------------------------------------------------------------------------------
|
|
# Ruud - Fixed a bug. The output should not be appended, but overwritten.
|
|
# open (HI,">>$OUTPUTDIR"."hdrinfo");
|
|
#-------------------------------------------------------------------------------
|
|
my $outfile = $outputdir."hdrinfo";
|
|
|
|
if ($first_call)
|
|
{
|
|
$first_call = $FALSE;
|
|
open (HI ,">", $outfile)
|
|
or die ("$subr_name - unable to open file $outfile for writing: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile for writing");
|
|
}
|
|
else
|
|
{
|
|
open (HI ,">>", $outfile)
|
|
or die ("$subr_name - unable to open file $outfile in append mode: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile in append mode");
|
|
}
|
|
|
|
print HI "\#$metric hdrlines=$number_of_header_lines\n";
|
|
my $len = 0;
|
|
for $HDR (@HDR)
|
|
{
|
|
print HI "$HDR\n";
|
|
gp_message ("debugXL", $subr_name, "HDR = $HDR\n");
|
|
}
|
|
close (HI);
|
|
if ($first_call)
|
|
{
|
|
gp_message ("debug", $subr_name, "wrote file $outfile");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "updated file $outfile");
|
|
}
|
|
#-----------------------------------------------
|
|
|
|
} #-- End of subroutine get_hdr_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the home directory and the location(s) of the configuration file on the
|
|
# current system.
|
|
#------------------------------------------------------------------------------
|
|
sub get_home_dir_and_rc_path
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($rc_file_name) = @_;
|
|
|
|
my @rc_file_paths;
|
|
my $target_cmd;
|
|
my $home_dir;
|
|
my $error_code;
|
|
|
|
$target_cmd = $g_mapped_cmds{"printenv"} . " HOME";
|
|
|
|
($error_code, $home_dir) = execute_system_cmd ($target_cmd);
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
my $msg = "cannot find a setting for HOME - please set this";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
else
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The home directory is known and we can define the locations for the
|
|
# configuration file.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
@rc_file_paths = (".", "$home_dir");
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths");
|
|
|
|
return ($home_dir, \@rc_file_paths);
|
|
|
|
} #-- End of subroutine get_home_dir_and_rc_path
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This subroutine generates a list with the hot functions.
|
|
#------------------------------------------------------------------------------
|
|
sub get_hot_functions
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($exp_dir_list_ref, $summary_metrics, $input_string) = @_;
|
|
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
|
|
my $cmd_output;
|
|
my $error_code;
|
|
my $expr_name;
|
|
my $first_metric;
|
|
my $gp_display_text_cmd;
|
|
my $ignore_value;
|
|
|
|
my @sort_fields = ();
|
|
|
|
$expr_name = join (" ", @exp_dir_list);
|
|
|
|
gp_message ("debug", $subr_name, "expr_name = $expr_name");
|
|
|
|
my $outputdir = append_forward_slash ($input_string);
|
|
|
|
my $script_file = $outputdir."gp-fsummary.script";
|
|
my $outfile = $outputdir."gp-fsummary.out";
|
|
my $result_file = $outputdir."gp-fsummary.stderr";
|
|
my $gp_error_file = $outputdir.$g_gp_error_logfile;
|
|
|
|
@sort_fields = split (":", $summary_metrics);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is extremely unlikely to happen, but if so, it is a fatal error.
|
|
#------------------------------------------------------------------------------
|
|
my $number_of_elements = scalar (@sort_fields);
|
|
|
|
gp_message ("debug", $subr_name, "number of fields in summary_metrics = $number_of_elements");
|
|
|
|
if ($number_of_elements == 0)
|
|
{
|
|
my $msg = "there are $number_of_elements in the metrics list";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the summary of the hot functions
|
|
#------------------------------------------------------------------------------
|
|
open (SCRIPT, ">", $script_file)
|
|
or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
|
|
gp_message ("debug", $subr_name, "opened script file $script_file for writing");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Check what this is about:
|
|
# Attributed User CPU Time=a.user : for calltree - see P37 in manual
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT "# limit 0\n";
|
|
print SCRIPT "limit 0\n";
|
|
print SCRIPT "# metrics $summary_metrics\n";
|
|
print SCRIPT "metrics $summary_metrics\n";
|
|
print SCRIPT "# thread_select all\n";
|
|
print SCRIPT "thread_select all\n";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Use first out of summary metrics as first (it doesn't matter which one)
|
|
# $first_metric = (split /:/,$summary_metrics)[0];
|
|
#------------------------------------------------------------------------------
|
|
|
|
$first_metric = $sort_fields[0];
|
|
|
|
print SCRIPT "# outfile $outfile\n";
|
|
print SCRIPT "outfile $outfile\n";
|
|
print SCRIPT "# sort $first_metric\n";
|
|
print SCRIPT "sort $first_metric\n";
|
|
print SCRIPT "# fsummary\n";
|
|
print SCRIPT "fsummary\n";
|
|
|
|
close SCRIPT;
|
|
|
|
my $gp_functions_cmd = "$GP_DISPLAY_TEXT -viewmode machine -compare off -script $script_file $expr_name";
|
|
|
|
gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the list of functions");
|
|
|
|
$gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file";
|
|
|
|
($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
$ignore_value = msg_display_text_failure ($gp_display_text_cmd,
|
|
$error_code,
|
|
$gp_error_file);
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd";
|
|
gp_message ("abort", $subr_name, $msg);
|
|
}
|
|
|
|
return ($outfile,\@sort_fields);
|
|
|
|
} #-- End of subroutine get_hot_functions
|
|
|
|
#------------------------------------------------------------------------------
|
|
# For a given function name, return the index into "function_info". This
|
|
# index gives access to all the meta data for the input function.
|
|
#------------------------------------------------------------------------------
|
|
sub get_index_function_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($routine_ref, $hex_address_ref, $function_info_ref) = @_;
|
|
|
|
my $routine = ${ $routine_ref };
|
|
my $hex_address = ${ $hex_address_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if this function has multiple occurrences.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "check for multiple occurrences");
|
|
|
|
my $current_address = $hex_address;
|
|
my $alt_name = $routine;
|
|
|
|
my $found_a_match;
|
|
my $index_into_function_info;
|
|
my $target_tag;
|
|
|
|
if (not exists ($g_multi_count_function{$routine}))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# There is only a single occurrence and it is straightforward to get the tag.
|
|
#--------------------------------------------------------------------------
|
|
## push (@final_function_names, $routine);
|
|
if (exists ($g_map_function_to_index{$routine}))
|
|
{
|
|
$index_into_function_info = $g_map_function_to_index{$routine}[0];
|
|
}
|
|
else
|
|
{
|
|
my $msg = "no entry for $routine in g_map_function_to_index";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The function name has more than one occurrence and we need to find the one
|
|
# that matches with the address.
|
|
#------------------------------------------------------------------------------
|
|
$found_a_match = $FALSE;
|
|
gp_message ("debug", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
|
|
for my $ref (keys @{ $g_map_function_to_index{$routine} })
|
|
{
|
|
my $ref_index = $g_map_function_to_index{$routine}[$ref];
|
|
my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
|
|
|
|
gp_message ("debug", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
|
|
gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Do this substitution when storing "addressobjtext" in function_info.
|
|
#------------------------------------------------------------------------------
|
|
$addr_offset =~ s/^@\d+://;
|
|
gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset");
|
|
if ($addr_offset eq $current_address)
|
|
{
|
|
$found_a_match = $TRUE;
|
|
$index_into_function_info = $ref_index;
|
|
last;
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If there is no match, something has gone really wrong and we bail out.
|
|
#------------------------------------------------------------------------------
|
|
if (not $found_a_match)
|
|
{
|
|
my $msg = "cannot find the mapping in function_info for function $routine";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
return (\$index_into_function_info);
|
|
|
|
} #-- End of subroutine get_index_function_info
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Get the setting for LANG, or assign a default if it is not set.
|
|
#-------------------------------------------------------------------------------
|
|
sub get_LANG_setting
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my $error_code;
|
|
my $lang_setting;
|
|
my $target_cmd;
|
|
my $command_string;
|
|
my $LANG;
|
|
|
|
$target_cmd = $g_mapped_cmds{"printenv"};
|
|
#------------------------------------------------------------------------------
|
|
# Use the printenv command to get the settings for LANG.
|
|
#------------------------------------------------------------------------------
|
|
if ($target_cmd eq "road_to_nowhere")
|
|
{
|
|
$error_code = 1;
|
|
}
|
|
else
|
|
{
|
|
$command_string = $target_cmd . " LANG";
|
|
($error_code, $lang_setting) = execute_system_cmd ($command_string);
|
|
}
|
|
|
|
if ($error_code == 0)
|
|
{
|
|
chomp ($lang_setting);
|
|
$LANG = $lang_setting;
|
|
}
|
|
else
|
|
{
|
|
$LANG = $g_default_setting_lang;
|
|
my $msg = "cannot find a setting for LANG - use a default setting";
|
|
gp_message ("warning", $subr_name, $msg);
|
|
}
|
|
|
|
return ($LANG);
|
|
|
|
} #-- End of subroutine get_LANG_setting
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This subroutine gathers the basic information about the metrics.
|
|
#------------------------------------------------------------------------------
|
|
sub get_metrics_data
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($exp_dir_list_ref, $outputdir, $outfile1, $outfile2, $error_file) = @_;
|
|
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
|
|
my $cmd_options;
|
|
my $cmd_output;
|
|
my $error_code;
|
|
my $expr_name;
|
|
my $metrics_cmd;
|
|
my $metrics_output;
|
|
my $target_cmd;
|
|
|
|
$expr_name = join (" ", @exp_dir_list);
|
|
|
|
gp_message ("debug", $subr_name, "expr_name = $expr_name");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is
|
|
# to get all the output in files $outfile1 and $outfile2. These are then
|
|
# parsed.
|
|
#------------------------------------------------------------------------------
|
|
$cmd_options = " -viewmode machine -compare off -thread_select all";
|
|
$cmd_options .= " -outfile $outfile2";
|
|
$cmd_options .= " -fsingle '<Total>' -metric_list $expr_name";
|
|
|
|
$metrics_cmd = "$GP_DISPLAY_TEXT $cmd_options 1> $outfile1 2> $error_file";
|
|
|
|
gp_message ("debug", $subr_name, "command used to gather the information:");
|
|
gp_message ("debug", $subr_name, $metrics_cmd);
|
|
|
|
($error_code, $metrics_output) = execute_system_cmd ($metrics_cmd);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Error handling. Any error that occurred is fatal and execution
|
|
# should be aborted by the caller.
|
|
#------------------------------------------------------------------------------
|
|
if ($error_code == 0)
|
|
{
|
|
gp_message ("debug", $subr_name, "metrics data in files $outfile1 and $outfile2");
|
|
}
|
|
else
|
|
{
|
|
$target_cmd = $g_mapped_cmds{"cat"} . " $error_file";
|
|
|
|
($error_code, $cmd_output) = execute_system_cmd ($target_cmd);
|
|
|
|
chomp ($cmd_output);
|
|
|
|
gp_message ("error", $subr_name, "contents of file $error_file:");
|
|
gp_message ("error", $subr_name, $cmd_output);
|
|
}
|
|
|
|
return ($error_code);
|
|
|
|
} #-- End of subroutine get_metrics_data
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Wrapper that returns the last part of the subroutine name. The assumption is
|
|
# that the last part of the input name is of the form "aa::bb" or just "bb".
|
|
#------------------------------------------------------------------------------
|
|
sub get_my_name
|
|
{
|
|
my $called_by = (caller (1))[3];
|
|
my @parts = split ("::", $called_by);
|
|
return ($parts[$#parts]);
|
|
|
|
## my ($the_full_name_ref) = @_;
|
|
|
|
## my $the_full_name = ${ $the_full_name_ref };
|
|
## my $last_part;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If the regex below fails, use the full name."
|
|
#------------------------------------------------------------------------------
|
|
## $last_part = $the_full_name;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Capture the last part if there are multiple parts separated by "::".
|
|
#------------------------------------------------------------------------------
|
|
## if ($the_full_name =~ /.*::(.+)$/)
|
|
## {
|
|
## if (defined ($1))
|
|
## {
|
|
## $last_part = $1;
|
|
## }
|
|
## }
|
|
|
|
## return (\$last_part);
|
|
|
|
} #-- End of subroutine get_my_name
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Determine the characteristics of the current system
|
|
#-------------------------------------------------------------------------------
|
|
sub get_system_config_info
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The output from the "uname" command is used for this. Although not all of
|
|
# these are currently used, we store all fields in separate variables.
|
|
#------------------------------------------------------------------------------
|
|
#
|
|
#------------------------------------------------------------------------------
|
|
# The options supported on uname from GNU coreutils 8.22:
|
|
#------------------------------------------------------------------------------
|
|
# -a, --all print all information, in the following order,
|
|
# except omit -p and -i if unknown:
|
|
# -s, --kernel-name print the kernel name
|
|
# -n, --nodename print the network node hostname
|
|
# -r, --kernel-release print the kernel release
|
|
# -v, --kernel-version print the kernel version
|
|
# -m, --machine print the machine hardware name
|
|
# -p, --processor print the processor type or "unknown"
|
|
# -i, --hardware-platform print the hardware platform or "unknown"
|
|
# -o, --operating-system print the operating system
|
|
#------------------------------------------------------------------------------
|
|
# Sample output:
|
|
# Linux ruudvan-vm-2-8-20200701 4.14.35-2025.400.8.el7uek.x86_64 #2 SMP Wed Aug 26 12:22:05 PDT 2020 x86_64 x86_64 x86_64 GNU/Linux
|
|
#------------------------------------------------------------------------------
|
|
my $subr_name = get_my_name ();
|
|
|
|
my $target_cmd;
|
|
my $hostname_current;
|
|
my $error_code;
|
|
my $ignore_output;
|
|
#------------------------------------------------------------------------------
|
|
# Test once if the command succeeds. This avoids we need to check every
|
|
# specific # command below.
|
|
#------------------------------------------------------------------------------
|
|
$target_cmd = $g_mapped_cmds{uname};
|
|
($error_code, $ignore_output) = execute_system_cmd ($target_cmd);
|
|
|
|
if ($error_code != 0)
|
|
#-------------------------------------------------------------------------------
|
|
# This is unlikely to happen, but you never know.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("abort", $subr_name, "failure to execute the uname command");
|
|
}
|
|
|
|
my $kernel_name = qx ($target_cmd -s); chomp ($kernel_name);
|
|
my $nodename = qx ($target_cmd -n); chomp ($nodename);
|
|
my $kernel_release = qx ($target_cmd -r); chomp ($kernel_release);
|
|
my $kernel_version = qx ($target_cmd -v); chomp ($kernel_version);
|
|
my $machine = qx ($target_cmd -m); chomp ($machine);
|
|
my $processor = qx ($target_cmd -p); chomp ($processor);
|
|
my $hardware_platform = qx ($target_cmd -i); chomp ($hardware_platform);
|
|
my $operating_system = qx ($target_cmd -o); chomp ($operating_system);
|
|
|
|
$local_system_config{"kernel_name"} = $kernel_name;
|
|
$local_system_config{"nodename"} = $nodename;
|
|
$local_system_config{"kernel_release"} = $kernel_release;
|
|
$local_system_config{"kernel_version"} = $kernel_version;
|
|
$local_system_config{"machine"} = $machine;
|
|
$local_system_config{"processor"} = $processor;
|
|
$local_system_config{"hardware_platform"} = $hardware_platform;
|
|
$local_system_config{"operating_system"} = $operating_system;
|
|
|
|
gp_message ("debug", $subr_name, "the output from the $target_cmd command is split into the following variables:");
|
|
gp_message ("debug", $subr_name, "kernel_name = $kernel_name");
|
|
gp_message ("debug", $subr_name, "nodename = $nodename");
|
|
gp_message ("debug", $subr_name, "kernel_release = $kernel_release");
|
|
gp_message ("debug", $subr_name, "kernel_version = $kernel_version");
|
|
gp_message ("debug", $subr_name, "machine = $machine");
|
|
gp_message ("debug", $subr_name, "processor = $processor");
|
|
gp_message ("debug", $subr_name, "hardware_platform = $hardware_platform");
|
|
gp_message ("debug", $subr_name, "operating_system = $operating_system");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the system we are running on is supported.
|
|
#------------------------------------------------------------------------------
|
|
my $is_supported = ${ check_support_for_processor (\$machine) };
|
|
|
|
if (not $is_supported)
|
|
{
|
|
gp_message ("error", $subr_name, "$machine is not supported");
|
|
exit (0);
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# The current hostname is used to compare against the hostname(s) found in the
|
|
# experiment directories.
|
|
#------------------------------------------------------------------------------
|
|
$target_cmd = $g_mapped_cmds{hostname};
|
|
$hostname_current = qx ($target_cmd); chomp ($hostname_current);
|
|
$error_code = ${^CHILD_ERROR_NATIVE};
|
|
|
|
if ($error_code == 0)
|
|
{
|
|
$local_system_config{"hostname_current"} = $hostname_current;
|
|
}
|
|
else
|
|
#-------------------------------------------------------------------------------
|
|
# This is unlikely to happen, but you never know.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("abort", $subr_name, "failure to execute the hostname command");
|
|
}
|
|
for my $key (sort keys %local_system_config)
|
|
{
|
|
gp_message ("debug", $subr_name, "local_system_config{$key} = $local_system_config{$key}");
|
|
}
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine get_system_config_info
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# This subroutine prints a message. Several types of messages are supported.
|
|
# In case the type is "abort", or "error", execution is terminated.
|
|
#
|
|
# Note that "debug", "warning", and "error" mode, the name of the calling
|
|
# subroutine is truncated to 30 characters. In case the name is longer,
|
|
# a warning message # is issued so you know this has happened.
|
|
#
|
|
# Note that we use lcfirst () and ucfirst () to enforce whether the first
|
|
# character is printed in lower or uppercase. It is nothing else than a
|
|
# convenience, but creates more consistency across messages.
|
|
#-------------------------------------------------------------------------------
|
|
sub gp_message
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($action, $caller_name, $comment_line) = @_;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# The debugXL identifier is special. It is accepted, but otherwise ignored.
|
|
# This allows to (temporarily) disable debug print statements, but keep them
|
|
# around.
|
|
#-------------------------------------------------------------------------------
|
|
my %supported_identifiers = (
|
|
"verbose" => "[Verbose]",
|
|
"debug" => "[Debug]",
|
|
"error" => "[Error]",
|
|
"warning" => "[Warning]",
|
|
"abort" => "[Abort]",
|
|
"assertion" => "[Assertion error]",
|
|
"diag" => "",
|
|
);
|
|
|
|
my $debug_size;
|
|
my $identifier;
|
|
my $fixed_size_name;
|
|
my $string_limit = 30;
|
|
my $strlen = length ($caller_name);
|
|
my $trigger_debug = $FALSE;
|
|
my $truncated_name;
|
|
my $msg;
|
|
|
|
if ($action =~ /debug\s*(.+)/)
|
|
{
|
|
if (defined ($1))
|
|
{
|
|
my $orig_value = $1;
|
|
$debug_size = lc ($1);
|
|
|
|
if ($debug_size =~ /^s$|^m$|^l$|^xl$/)
|
|
{
|
|
if ($g_debug_size{$debug_size})
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# All we need to know is whether a debug action is requested and whether the
|
|
# size has been enabled. By setting $action to "debug", the code below is
|
|
# simplified. Note that only using $trigger_debug below is actually sufficient.
|
|
#-------------------------------------------------------------------------------
|
|
$trigger_debug = $TRUE;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
die "$subr_name: debug size $orig_value is not supported";
|
|
}
|
|
$action = "debug";
|
|
}
|
|
}
|
|
elsif ($action eq "debug")
|
|
{
|
|
$trigger_debug = $TRUE;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Catch any non-supported identifier.
|
|
#-------------------------------------------------------------------------------
|
|
if (defined ($supported_identifiers{$action}))
|
|
{
|
|
$identifier = $supported_identifiers{$action};
|
|
}
|
|
else
|
|
{
|
|
die ("$subr_name - input error: $action is not supported");
|
|
}
|
|
if (($action eq "debug") and ($g_user_settings{"debug"}{"current_value"} eq "off"))
|
|
{
|
|
$trigger_debug = $FALSE;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Unconditionally buffer all warning messages. These are meant to be displayed
|
|
# separately.
|
|
#-------------------------------------------------------------------------------
|
|
if ($action eq "warning")
|
|
{
|
|
push (@g_warning_messages, ucfirst ($comment_line));
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Quick return in several cases. Note that "debug", "verbose", "warning", and
|
|
# "diag" messages are suppressed in quiet mode, but "error", "abort" and
|
|
# "assertion" always pass.
|
|
#-------------------------------------------------------------------------------
|
|
if ((
|
|
($action eq "verbose") and (not $g_verbose))
|
|
or (($action eq "debug") and (not $trigger_debug))
|
|
or (($action eq "verbose") and ($g_quiet))
|
|
or (($action eq "debug") and ($g_quiet))
|
|
or (($action eq "warning") and (not $g_warnings))
|
|
or (($action eq "diag") and ($g_quiet)))
|
|
{
|
|
return (0);
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# In diag mode, just print the input line and nothing else.
|
|
#-------------------------------------------------------------------------------
|
|
if ((
|
|
$action eq "debug")
|
|
or ($action eq "abort")
|
|
or ($action eq "warning")
|
|
or ($action eq "assertion")
|
|
or ($action eq "error"))
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# Construct the string to be printed. Include an identifier and the name of
|
|
# the function.
|
|
#-------------------------------------------------------------------------------
|
|
if ($strlen > $string_limit)
|
|
{
|
|
$truncated_name = substr ($caller_name, 0, $string_limit);
|
|
$fixed_size_name = sprintf ("%-"."$string_limit"."s", $truncated_name);
|
|
print "Warning in $subr_name - the name of the caller is: $caller_name\n";
|
|
print "Warning in $subr_name - the string length is $strlen and exceeds $string_limit\n";
|
|
}
|
|
else
|
|
{
|
|
$fixed_size_name = sprintf ("%-"."$string_limit"."s", $caller_name);
|
|
}
|
|
|
|
if (($action eq "error") or ($action eq "abort"))
|
|
#-------------------------------------------------------------------------------
|
|
# Enforce that the message starts with a lowercase symbol. Since these are
|
|
# user errors, the name of the routine is not shown. The same for "abort".
|
|
# If you want to display the routine name too, use an assertion.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
printf ("%-9s %s\n", $identifier, lcfirst ($comment_line));
|
|
}
|
|
elsif ($action eq "assertion")
|
|
#-------------------------------------------------------------------------------
|
|
# Enforce that the message starts with a lowercase symbol.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line);
|
|
}
|
|
elsif (($action eq "debug") and ($trigger_debug))
|
|
#-------------------------------------------------------------------------------
|
|
# Debug messages are printed "as is". Avoids issues when searching for them ;-)
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line);
|
|
}
|
|
else
|
|
#-------------------------------------------------------------------------------
|
|
# Enforce that the message starts with a lowercase symbol.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, lcfirst ($comment_line));
|
|
}
|
|
}
|
|
elsif ($action eq "verbose")
|
|
#-------------------------------------------------------------------------------
|
|
# The first character in the verbose message is capatilized.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
printf ("%s\n", ucfirst ($comment_line));
|
|
}
|
|
elsif ($action eq "diag")
|
|
#-------------------------------------------------------------------------------
|
|
# The diag messages are meant to be diagnostics. Only the comment line is
|
|
# printed.
|
|
#-------------------------------------------------------------------------------
|
|
{
|
|
printf ("%s\n", $comment_line);
|
|
return (0);
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Terminate execution in case the identifier is "abort".
|
|
#-------------------------------------------------------------------------------
|
|
if (($action eq "abort") or ($action eq "assertion"))
|
|
{
|
|
## print "ABORT temporarily disabled for testing purposes\n";
|
|
exit (-1);
|
|
}
|
|
else
|
|
{
|
|
return (0);
|
|
}
|
|
|
|
} #-- End of subroutine gp_message
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Dynamically load the modules needed. Returns a list with the modules that
|
|
# could not be loaded.
|
|
#------------------------------------------------------------------------------
|
|
sub handle_module_availability
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
gp_message ("verbose", $subr_name, "Handling module requirements");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is clunky at best, but there is a chicken egg problem here. For the
|
|
# man page to be generated, the --help and --version options need to work,
|
|
# but this part of the code only works if the "stat" function is available.
|
|
# The "feature qw (state)" is required for the code to compile.
|
|
#
|
|
# TBD: Consider using global variables and to decouple parts of the option
|
|
# handling.
|
|
#;
|
|
## my @modules_used = ("feature",
|
|
## "File::stat",
|
|
#------------------------------------------------------------------------------
|
|
my @modules_used = (
|
|
"List::Util",
|
|
"Cwd",
|
|
"File::Basename",
|
|
"File::stat",
|
|
"POSIX",
|
|
"bigint",
|
|
"bignum");
|
|
|
|
my @missing_modules = ();
|
|
my $cmd;
|
|
my $result;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This loop checks for the availability of the modules and if so, imports
|
|
# the module.
|
|
#
|
|
# The names of missing modules, if any, are stored and printed in the error
|
|
# handling section below.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (0 .. $#modules_used)
|
|
{
|
|
my $m = $modules_used[$i];
|
|
if (eval "require $m;")
|
|
{
|
|
if ($m eq "feature")
|
|
{
|
|
$cmd = $m . "->import ( qw (state))";
|
|
}
|
|
elsif ($m eq "List::Util")
|
|
{
|
|
$cmd = $m . "->import ( qw (min max))";
|
|
}
|
|
elsif ($m eq "bigint")
|
|
{
|
|
$cmd = $m . "->import ( qw (hex))";
|
|
}
|
|
else
|
|
{
|
|
$cmd = $m . "->import";
|
|
}
|
|
$cmd .= ";";
|
|
$result = eval ("$cmd");
|
|
gp_message ("debugM", $subr_name, "cmd = $cmd");
|
|
}
|
|
else
|
|
{
|
|
push (@missing_modules, $m);
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Count the number of missing modules. It is upon the caller to decide what
|
|
# to do in case of errors. Currently, execution is aborted.
|
|
#------------------------------------------------------------------------------
|
|
my $errors = scalar (@missing_modules);
|
|
|
|
return (\$errors, \@missing_modules);
|
|
|
|
} #-- End of subroutine handle_module_availability
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the HTML with the experiment summary.
|
|
#------------------------------------------------------------------------------
|
|
sub html_generate_exp_summary
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($outputdir_ref, $experiment_data_ref) = @_;
|
|
|
|
my $outputdir = ${ $outputdir_ref };
|
|
my @experiment_data = @{ $experiment_data_ref };
|
|
my $file_title;
|
|
my $outfile;
|
|
my $page_title;
|
|
my $size_text;
|
|
my $position_text;
|
|
my $html_header;
|
|
my $html_home;
|
|
my $html_title_header;
|
|
my $html_acknowledgement;
|
|
my $html_end;
|
|
my @html_exp_table_data = ();
|
|
my $html_exp_table_data_ref;
|
|
my @table_execution_stats = ();
|
|
my $table_execution_stats_ref;
|
|
|
|
gp_message ("debug", $subr_name, "outputdir = $outputdir");
|
|
$outputdir = append_forward_slash ($outputdir);
|
|
gp_message ("debug", $subr_name, "outputdir = $outputdir");
|
|
|
|
$file_title = "Experiment information";
|
|
$page_title = "Experiment Information";
|
|
$size_text = "h2";
|
|
$position_text = "center";
|
|
$html_header = ${ create_html_header (\$file_title) };
|
|
$html_home = ${ generate_home_link ("right") };
|
|
|
|
$html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) };
|
|
|
|
$outfile = $outputdir . $g_html_base_file_name{"experiment_info"} . ".html";
|
|
open (EXP_INFO, ">", $outfile)
|
|
or die ("unable to open $outfile for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile for writing");
|
|
|
|
print EXP_INFO $html_header;
|
|
print EXP_INFO $html_home;
|
|
print EXP_INFO $html_title_header;
|
|
|
|
($html_exp_table_data_ref, $table_execution_stats_ref) = html_generate_table_data ($experiment_data_ref);
|
|
|
|
@html_exp_table_data = @{ $html_exp_table_data_ref };
|
|
@table_execution_stats = @{ $table_execution_stats_ref };
|
|
|
|
print EXP_INFO "$_" for @html_exp_table_data;
|
|
;
|
|
## print EXP_INFO "<pre>\n";
|
|
## print EXP_INFO "$_\n" for @html_caller_callee;
|
|
## print EXP_INFO "</pre>\n";
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Get the acknowledgement, return to main link, and final html statements.
|
|
#-------------------------------------------------------------------------------
|
|
$html_home = ${ generate_home_link ("left") };
|
|
$html_acknowledgement = ${ create_html_credits () };
|
|
$html_end = ${ terminate_html_document () };
|
|
|
|
print EXP_INFO $html_home;
|
|
print EXP_INFO "<br>\n";
|
|
print EXP_INFO $html_acknowledgement;
|
|
print EXP_INFO $html_end;
|
|
|
|
close (EXP_INFO);
|
|
|
|
return (\@table_execution_stats);
|
|
|
|
} #-- End of subroutine html_generate_exp_summary
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Generate the entries for the tables with the experiment info.
|
|
#-------------------------------------------------------------------------------
|
|
sub html_generate_table_data
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($experiment_data_ref) = @_;
|
|
|
|
my @experiment_data = ();
|
|
my @html_exp_table_data = ();
|
|
my $html_line;
|
|
## my $html_header_line;
|
|
my $entry_name;
|
|
my $key;
|
|
my $size_text;
|
|
my $position_text;
|
|
my $title_table_1;
|
|
my $title_table_2;
|
|
my $title_table_3;
|
|
my $title_table_summary;
|
|
my $html_table_title;
|
|
|
|
my @experiment_table_1_def = ();
|
|
my @experiment_table_2_def = ();
|
|
my @experiment_table_3_def = ();
|
|
my @exp_table_summary_def = ();
|
|
my @experiment_table_1 = ();
|
|
my @experiment_table_2 = ();
|
|
my @experiment_table_3 = ();
|
|
my @exp_table_summary = ();
|
|
my @exp_table_selection = ();
|
|
|
|
@experiment_data = @{ $experiment_data_ref };
|
|
|
|
for my $i (sort keys @experiment_data)
|
|
{
|
|
for my $fields (sort keys %{ $experiment_data[$i] })
|
|
{
|
|
gp_message ("debugXL", $subr_name, "$i => experiment_data[$i]{$fields} = $experiment_data[$i]{$fields}");
|
|
}
|
|
}
|
|
|
|
$title_table_1 = "Target System Configuration";
|
|
$title_table_2 = "Experiment Statistics";
|
|
$title_table_3 = "Run Time Statistics";
|
|
$title_table_summary = "Main Statistics";
|
|
|
|
$size_text = "h3";
|
|
$position_text = "left";
|
|
|
|
push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"};
|
|
push @experiment_table_1_def, { name => "Hostname" , key => "hostname"};
|
|
push @experiment_table_1_def, { name => "Operating system", key => "OS"};
|
|
push @experiment_table_1_def, { name => "Architecture", key => "architecture"};
|
|
push @experiment_table_1_def, { name => "Page size", key => "page_size"};
|
|
|
|
push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"};
|
|
push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"};
|
|
push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"};
|
|
push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"};
|
|
|
|
push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"};
|
|
## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"};
|
|
push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"};
|
|
## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"};
|
|
push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"};
|
|
## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"};
|
|
|
|
push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"};
|
|
push @exp_table_summary_def, { name => "Hostname" , key => "hostname"};
|
|
push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"};
|
|
push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"};
|
|
push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"};
|
|
|
|
$html_table_title = ${ generate_a_header (\$title_table_1, \$size_text, \$position_text) };
|
|
|
|
push (@html_exp_table_data, $html_table_title);
|
|
|
|
@experiment_table_1 = @{ create_table (\@experiment_data, \@experiment_table_1_def) };
|
|
|
|
push (@html_exp_table_data, @experiment_table_1);
|
|
|
|
$html_table_title = ${ generate_a_header (\$title_table_2, \$size_text, \$position_text) };
|
|
|
|
push (@html_exp_table_data, $html_table_title);
|
|
|
|
@experiment_table_2 = @{ create_table (\@experiment_data, \@experiment_table_2_def) };
|
|
|
|
push (@html_exp_table_data, @experiment_table_2);
|
|
|
|
$html_table_title = ${ generate_a_header (\$title_table_3, \$size_text, \$position_text) };
|
|
|
|
push (@html_exp_table_data, $html_table_title);
|
|
|
|
@experiment_table_3 = @{ create_table (\@experiment_data, \@experiment_table_3_def) };
|
|
|
|
push (@html_exp_table_data, @experiment_table_3);
|
|
|
|
$html_table_title = ${ generate_a_header (\$title_table_summary, \$size_text, \$position_text) };
|
|
|
|
push (@exp_table_summary, $html_table_title);
|
|
|
|
@exp_table_selection = @{ create_table (\@experiment_data, \@exp_table_summary_def) };
|
|
|
|
push (@exp_table_summary, @exp_table_selection);
|
|
|
|
return (\@html_exp_table_data, \@exp_table_summary);
|
|
|
|
} #-- End of subroutine html_generate_table_data
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the HTML text to print in case a file is empty.
|
|
#------------------------------------------------------------------------------
|
|
sub html_text_empty_file
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($comment_ref, $error_file_ref) = @_;
|
|
|
|
my $comment;
|
|
my $error_file;
|
|
my $error_message;
|
|
my $file_title;
|
|
my $html_end;
|
|
my $html_header;
|
|
my $html_home;
|
|
|
|
my @html_empty_file = ();
|
|
|
|
$comment = ${ $comment_ref };
|
|
$error_file = ${ $error_file_ref };
|
|
|
|
$file_title = "File is empty";
|
|
$html_header = ${ create_html_header (\$file_title) };
|
|
$html_end = ${ terminate_html_document () };
|
|
$html_home = ${ generate_home_link ("left") };
|
|
|
|
push (@html_empty_file, $html_header);
|
|
|
|
$error_message = "<b>" . $comment . "</b>";
|
|
$error_message = set_background_color_string ($error_message, $g_html_color_scheme{"error_message"});
|
|
push (@html_empty_file, $error_message);
|
|
|
|
if (not is_file_empty ($error_file))
|
|
{
|
|
$error_message = "<p><em>Check file $error_file for more information</em></p>";
|
|
}
|
|
push (@html_empty_file, $error_message);
|
|
push (@html_empty_file, $html_home);
|
|
push (@html_empty_file, "<br>");
|
|
push (@html_empty_file, $g_html_credits_line);
|
|
push (@html_empty_file, $html_end);
|
|
|
|
return (\@html_empty_file);
|
|
|
|
} #-- End of subroutine html_text_empty_file
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This subroutine checks if a file is empty and returns $TRUE or $FALSE.
|
|
#------------------------------------------------------------------------------
|
|
sub is_file_empty
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($filename) = @_;
|
|
|
|
my $size;
|
|
my $file_stat;
|
|
my $is_empty;
|
|
|
|
chomp ($filename);
|
|
|
|
if (not -e $filename)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The return value is used in the caller. This is why we return the empty
|
|
# string in case the file does not exist.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "filename = $filename not found");
|
|
$is_empty = $TRUE;
|
|
}
|
|
else
|
|
{
|
|
$file_stat = stat ($filename);
|
|
$size = $file_stat->size;
|
|
$is_empty = ($size == 0) ? $TRUE : $FALSE;
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "filename = $filename size = $size is_empty = $is_empty");
|
|
|
|
return ($is_empty);
|
|
|
|
} #-- End of subroutine is_file_empty
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if a file is executable and return $TRUE or $FALSE.
|
|
#------------------------------------------------------------------------------
|
|
sub is_file_executable
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($filename) = @_;
|
|
|
|
my $file_permissions;
|
|
my $index_offset;
|
|
my $is_executable;
|
|
my $mode;
|
|
my $number_of_bytes;
|
|
my @permission_settings = ();
|
|
my %permission_values = ();
|
|
|
|
chomp ($filename);
|
|
|
|
gp_message ("debug", $subr_name, "check if filename = $filename is executable");
|
|
|
|
if (not -e $filename)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The return value is used in the caller. This is why we return the empty
|
|
# string in case the file does not exist.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "filename = $filename not found");
|
|
$is_executable = $FALSE;
|
|
}
|
|
else
|
|
{
|
|
$mode = stat ($filename)->mode;
|
|
|
|
gp_message ("debugXL", $subr_name, "mode = $mode");
|
|
#------------------------------------------------------------------------------
|
|
# Get username. We currently do not do anything with this though and the
|
|
# code is commented out.
|
|
#
|
|
# my $my_name = getlogin () || getpwuid($<) || "Kilroy";;
|
|
# gp_message ("debug", $subr_name, "my_name = $my_name");
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Convert file permissions to octal, split the individual numbers and store
|
|
# the values for the respective users.
|
|
#------------------------------------------------------------------------------
|
|
$file_permissions = sprintf("%o", $mode & 07777);
|
|
|
|
@permission_settings = split (//, $file_permissions);
|
|
|
|
$number_of_bytes = scalar (@permission_settings);
|
|
|
|
gp_message ("debugXL", $subr_name, "file_permissions = $file_permissions");
|
|
gp_message ("debugXL", $subr_name, "permission_settings = @permission_settings");
|
|
gp_message ("debugXL", $subr_name, "number_of_settings = $number_of_bytes");
|
|
|
|
if ($number_of_bytes == 4)
|
|
{
|
|
$index_offset = 1;
|
|
}
|
|
elsif ($number_of_bytes == 3)
|
|
{
|
|
$index_offset = 0;
|
|
}
|
|
else
|
|
{
|
|
my $msg = "unexpected number of $number_of_bytes bytes " .
|
|
"in permission settings: @permission_settings";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
$permission_values{user} = $permission_settings[$index_offset++];
|
|
$permission_values{group} = $permission_settings[$index_offset++];
|
|
$permission_values{other} = $permission_settings[$index_offset];
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The executable bit should be set for user, group and other. If this fails
|
|
# we mark the file as not executable. Note that this is gprofng specific.
|
|
#------------------------------------------------------------------------------
|
|
$is_executable = $TRUE;
|
|
for my $k (keys %permission_values)
|
|
{
|
|
my $msg = "permission_values{" . $k . "} = " .
|
|
$permission_values{$k};
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
if ($permission_values{$k} % 2 == 0)
|
|
{
|
|
$is_executable = $FALSE;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "is_executable = $is_executable");
|
|
|
|
return ($is_executable);
|
|
|
|
} #-- End of subroutine is_file_executable
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# TBD.
|
|
#-------------------------------------------------------------------------------
|
|
sub name_regex
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($metric_description_ref, $metrics, $field, $file) = @_;
|
|
|
|
my %metric_description = %{ $metric_description_ref };
|
|
|
|
my @splitted_metrics;
|
|
my $splitted_metrics;
|
|
my $m;
|
|
my $mf;
|
|
my $nf;
|
|
my $re;
|
|
my $Xre;
|
|
my $noPCfile;
|
|
my @reported_metrics;
|
|
my $reported_metrics;
|
|
my $hdr_regex;
|
|
my $hdr_href_regex;
|
|
my $hdr_src_regex;
|
|
my $new_metrics;
|
|
my $pre;
|
|
my $post;
|
|
my $rat;
|
|
my @moo = ();
|
|
|
|
my $gp_metrics_file;
|
|
my $gp_metrics_dir;
|
|
my $suffix_not_used;
|
|
|
|
my $is_calls = $FALSE;
|
|
my $is_calltree = $FALSE;
|
|
|
|
gp_message ("debugXL", $subr_name,"1:metrics->$metrics<- field->$field<- file->$file<-");
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# According to https://perldoc.perl.org/File::Basename, both dirname and
|
|
# basename are not reliable and fileparse () is recommended instead.
|
|
#
|
|
# Note that $gp_metrics_dir has a trailing "/".
|
|
#-------------------------------------------------------------------------------
|
|
($gp_metrics_file, $gp_metrics_dir, $suffix_not_used) = fileparse ($file, ".sort.func-PC");
|
|
|
|
gp_message ("debugXL", $subr_name, "gp_metrics_dir = $gp_metrics_dir gp_metrics_file = $gp_metrics_file");
|
|
gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used");
|
|
|
|
if ($gp_metrics_file eq "calls")
|
|
{
|
|
$is_calls = $TRUE;
|
|
}
|
|
if ($gp_metrics_file eq "calltree")
|
|
{
|
|
$is_calltree = $TRUE;
|
|
}
|
|
|
|
$gp_metrics_file = "gp-metrics-" . $gp_metrics_file . "-PC";
|
|
$gp_metrics_file = $gp_metrics_dir . $gp_metrics_file;
|
|
|
|
gp_message ("debugXL", $subr_name, "gp_metrics_file is $gp_metrics_file");
|
|
|
|
open (GP_METRICS, "<", $gp_metrics_file)
|
|
or die ("$subr_name - unable to open gp_metrics file $gp_metrics_file for reading - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $gp_metrics_file for reading");
|
|
|
|
$new_metrics = $metrics;
|
|
|
|
while (<GP_METRICS>)
|
|
{
|
|
$rat = $_;
|
|
chomp ($rat);
|
|
gp_message ("debugXL", $subr_name, "rat = $rat - new_metrics = $new_metrics");
|
|
#-------------------------------------------------------------------------------
|
|
# Capture the string after "Current metrics:" and if it ends with ":name",
|
|
# remove it.
|
|
#-------------------------------------------------------------------------------
|
|
if ($rat =~ /^\s*Current metrics:\s*(.*)$/)
|
|
{
|
|
$new_metrics = $1;
|
|
if ($new_metrics =~ /^(.*):name$/)
|
|
{
|
|
$new_metrics = $1;
|
|
}
|
|
last;
|
|
}
|
|
}
|
|
close (GP_METRICS);
|
|
|
|
if ($is_calls or $is_calltree)
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# Remove any inclusive metrics from the list.
|
|
#-------------------------------------------------------------------------------
|
|
while ($new_metrics =~ /(.*)(i\.[^:]+)(.*)$/)
|
|
{
|
|
$pre = $1;
|
|
$post = $3;
|
|
gp_message ("debugXL", $subr_name, "1b: new_metrics = $new_metrics pre = $pre post = $post");
|
|
if (substr ($post,0,1) eq ":")
|
|
{
|
|
$post = substr ($post,1);
|
|
}
|
|
$new_metrics = $pre.$post;
|
|
}
|
|
}
|
|
|
|
$metrics = $new_metrics;
|
|
|
|
gp_message ("debugXL", $subr_name, "2:metrics->$metrics<- field->$field<- file->$file<-");
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Find the line starting with "address:" and strip this part away.
|
|
#-------------------------------------------------------------------------------
|
|
if ($metrics =~ /^address:(.*)/)
|
|
{
|
|
$reported_metrics = $1;
|
|
#-------------------------------------------------------------------------------
|
|
# Focus on the filename ending with "-PC". When found, strip this part away.
|
|
#-------------------------------------------------------------------------------
|
|
if ($file =~ /^(.*)-PC$/)
|
|
{
|
|
$noPCfile = $1;
|
|
if ($noPCfile =~ /^(.*)functions.sort.func$/)
|
|
{
|
|
$noPCfile = $1."functions.func";
|
|
}
|
|
push (@moo, "$reported_metrics\n");
|
|
}
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Split the list into an array with the individual metrics.
|
|
#
|
|
# TBD: This should be done only once!
|
|
#-------------------------------------------------------------------------------
|
|
@reported_metrics = split (":", $reported_metrics);
|
|
for my $i (@reported_metrics)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "reported_metrics = $i");
|
|
}
|
|
|
|
$hdr_regex = "^\\s*";
|
|
$hdr_href_regex = "^\\s*";
|
|
$hdr_src_regex = "^(\\s+|<i>\\s+)";
|
|
|
|
for my $m (@reported_metrics)
|
|
{
|
|
|
|
my $description = ${ retrieve_metric_description (\$m, \%metric_description) };
|
|
gp_message ("debugXL", $subr_name, "m = $m description = $description");
|
|
if (substr ($m,0,1) eq "e")
|
|
{
|
|
push (@moo,"$m:$description\n");
|
|
$hdr_regex .= "(Excl\\.\.*)";
|
|
$hdr_href_regex .= "(<a.*>)(Excl\\.)(<\/a>)([^<]+)";
|
|
$hdr_src_regex .= "(Excl\\.\.*)";
|
|
next;
|
|
}
|
|
if (substr ($m,0,1) eq "i")
|
|
{
|
|
push (@moo,"$m:$description\n");
|
|
$hdr_regex .= "(Incl\\.\.*)";
|
|
$hdr_href_regex .= "(<a.*>)(Incl\\.)(<\/a>)([^<]+)";
|
|
$hdr_src_regex .= "(Incl\\.\.*)";
|
|
next;
|
|
}
|
|
if (substr ($m,0,1) eq "a")
|
|
{
|
|
my $a;
|
|
my $am;
|
|
$a = $m;
|
|
$a =~ s/^a/e/;
|
|
$am = ${ retrieve_metric_description (\$a, \%metric_description) };
|
|
$am =~ s/Exclusive/Attributed/;
|
|
push (@moo,"$m:$am\n");
|
|
$hdr_regex .= "(Attr\\.\.*)";
|
|
$hdr_href_regex .= "(<a.*>)(Attr\\.)(<\/a>)([^<]+)";
|
|
$hdr_src_regex .= "(Attr\\.\.*)";next;
|
|
}
|
|
}
|
|
|
|
$hdr_regex .= "(Name\.*)";
|
|
$hdr_href_regex .= "(Name\.*)";
|
|
|
|
@splitted_metrics = split (":","$metrics");
|
|
$nf = scalar (@splitted_metrics);
|
|
gp_message ("debug", $subr_name,"number of fields in $metrics -> $nf");
|
|
|
|
open (ZMETRICS, ">", "$noPCfile.metrics")
|
|
or die ("Not able to open file $noPCfile.metrics for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.metrics for writing");
|
|
|
|
print ZMETRICS @moo;
|
|
close (ZMETRICS);
|
|
|
|
gp_message ("debug", $subr_name, "wrote file $noPCfile.metrics");
|
|
|
|
open (XREGEXP, ">", "$noPCfile.c.regex")
|
|
or die ("Not able to open file $noPCfile.c.regex for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.c.regex for writing");
|
|
|
|
print XREGEXP "\# Number of metric fields\n";
|
|
print XREGEXP "$nf\n";
|
|
print XREGEXP "\# Header regex\n";
|
|
print XREGEXP "$hdr_regex\n";
|
|
print XREGEXP "\# href Header regex\n";
|
|
print XREGEXP "$hdr_href_regex\n";
|
|
print XREGEXP "\# src Header regex\n";
|
|
print XREGEXP "$hdr_src_regex\n";
|
|
|
|
$mf = 1;
|
|
#---------------------------------------------------------------------------
|
|
# Find the index of "field" in the metric list, plus one.
|
|
#---------------------------------------------------------------------------
|
|
if ( ($field eq "functions") or ($field eq "calls") or ($field eq "calltree"))
|
|
{
|
|
$mf = $nf + 1;
|
|
}
|
|
else
|
|
{
|
|
for my $candidate_metric (@splitted_metrics)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "field = $field candidate_metric = $candidate_metric and mf = $mf");
|
|
if ($candidate_metric eq $field)
|
|
{
|
|
last;
|
|
}
|
|
$mf++;
|
|
}
|
|
}
|
|
gp_message ("debugXL", $subr_name, "Final value mf = $mf");
|
|
|
|
if ($mf == 1)
|
|
{
|
|
$re = "^\\s*(\\S+)"; # metric value
|
|
}
|
|
else
|
|
{
|
|
$re = "^\\s*\\S+";
|
|
}
|
|
$Xre = "^\\s*(\\S+)";
|
|
|
|
$m = 2;
|
|
while (--$nf)
|
|
{
|
|
if ($nf)
|
|
{
|
|
if ($m == $mf)
|
|
{
|
|
$re .= "\\s+(\\S+)"; # metric value
|
|
}
|
|
else
|
|
{
|
|
$re .= "\\s+\\S+";
|
|
}
|
|
if ($nf != 1)
|
|
{
|
|
$Xre .= "\\s+(\\S+)";
|
|
}
|
|
$m++;
|
|
}
|
|
}
|
|
|
|
if ($field eq "calltree")
|
|
{
|
|
$re .= "\\s+.*\\+-(.*)"; # name
|
|
$Xre .= "\\s+.*\\+-(.*)\$"; # name (Right?)
|
|
}
|
|
else
|
|
{
|
|
$re .= "\\s+(.*)"; # name
|
|
$Xre .= "\\s+(.*)\$"; # name
|
|
}
|
|
|
|
print XREGEXP "\# Metrics and Name regex\n";
|
|
print XREGEXP "$Xre\n";
|
|
close (XREGEXP);
|
|
|
|
gp_message ("debug", $subr_name, "wrote file $noPCfile.c.regex");
|
|
gp_message ("debugXL", $subr_name, "on return Xre = $Xre");
|
|
gp_message ("debugXL", $subr_name, "on return re = $re");
|
|
|
|
return ($re);
|
|
|
|
} #-- End of subroutine name_regex
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# TBD
|
|
#-------------------------------------------------------------------------------
|
|
sub nosrc
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_string) = @_;
|
|
|
|
my $directory_name = append_forward_slash ($input_string);
|
|
my $LANG = $g_locale_settings{"LANG"};
|
|
my $result_file = $directory_name."no_source.html";
|
|
|
|
gp_message ("debug", $subr_name, "result_file = $result_file");
|
|
|
|
open (NS, ">", $result_file)
|
|
or die ("$subr_name: cannot open file $result_file for writing - '$!'");
|
|
|
|
print NS "<!doctype html public \"-//w3c//dtd html 3.2//en\">\n<html lang=\"$LANG\">\n<head>\n".
|
|
"<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" .
|
|
"<title>No source</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."><pre>\n";
|
|
print NS "<a name=\"line1\"></a><font color=#C80707>"."No source was found"."</font>\n"; # red font
|
|
print NS "</pre>\n<pre>Output generated by $version_info</pre>\n";
|
|
print NS "</body></html>\n";
|
|
|
|
close (NS);
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine nosrc
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD.
|
|
#------------------------------------------------------------------------------
|
|
sub numerically
|
|
{
|
|
my $f1;
|
|
my $f2;
|
|
|
|
if ($a =~ /^([^\d]*)(\d+)/)
|
|
{
|
|
$f1 = int ($2);
|
|
if ($b=~ /^([^\d]*)(\d+)/)
|
|
{
|
|
$f2 = int ($2);
|
|
$f1 == $f2 ? 0 : ($f1 < $f2 ? -1 : +1);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
return ($a <=> $b);
|
|
}
|
|
} #-- End of subroutine numerically
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse the user options. Also perform a basic check. More checks and also
|
|
# some specific to the option will be performed after this subroutine.
|
|
#------------------------------------------------------------------------------
|
|
sub parse_and_check_user_options
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($no_of_args_ref, $option_list_ref) = @_;
|
|
|
|
my $no_of_args = ${ $no_of_args_ref };
|
|
my @option_list = @{ $option_list_ref };
|
|
|
|
my @exp_dir_list;
|
|
|
|
my $arg;
|
|
my $calltree_value;
|
|
my $debug_value;
|
|
my $default_metrics_value;
|
|
my $func_limit_value;
|
|
my $found_exp_dir = $FALSE;
|
|
my $ignore_metrics_value;
|
|
my $ignore_value;
|
|
my $message;
|
|
my $outputdir_value;
|
|
my $quiet_value;
|
|
my $hp_value;
|
|
my $valid;
|
|
my $verbose_value;
|
|
|
|
$no_of_args++;
|
|
|
|
gp_message ("debug", $subr_name, "no_of_args = $no_of_args");
|
|
gp_message ("debug", $subr_name, "option_list = @option_list");
|
|
|
|
my $option_errors = 0;
|
|
|
|
while (defined ($arg = shift @ARGV))
|
|
{
|
|
gp_message ("debug", $subr_name, "parsing options arg = $arg");
|
|
gp_message ("debug", $subr_name, "parsing options \@ARGV = @ARGV");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The gprofng driver adds this option. We need to get rid of it.
|
|
#------------------------------------------------------------------------------
|
|
next if ($arg eq "--whoami=gprofng display html");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse the input options and check for the values to be valid.
|
|
#
|
|
# Valid values are stored in the main option table.
|
|
#
|
|
# TBD: The early check handles some of these already and the duplicates
|
|
# can be removed. Be aware of some global settings though.
|
|
#------------------------------------------------------------------------------
|
|
if ($arg eq "--version")
|
|
{
|
|
print_version_info ();
|
|
exit (0);
|
|
}
|
|
elsif ($arg eq "--help")
|
|
{
|
|
$ignore_value = print_help_info ();
|
|
exit (0);
|
|
}
|
|
elsif (($arg eq "-v") or ($arg eq "--verbose"))
|
|
{
|
|
$verbose_value = shift @ARGV;
|
|
$valid = check_user_option ("verbose", $verbose_value);
|
|
if (not $valid)
|
|
{
|
|
$option_errors++;
|
|
}
|
|
else
|
|
{
|
|
$g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE;
|
|
}
|
|
next;
|
|
}
|
|
elsif (($arg eq "-w") or ($arg eq "--warnings"))
|
|
{
|
|
my $warnings_value = shift @ARGV;
|
|
$valid = check_user_option ("warnings", $warnings_value);
|
|
if (not $valid)
|
|
{
|
|
$option_errors++;
|
|
}
|
|
else
|
|
{
|
|
$g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE;
|
|
}
|
|
next;
|
|
}
|
|
elsif (($arg eq "-d") or ($arg eq "--debug"))
|
|
{
|
|
$debug_value = shift @ARGV;
|
|
$valid = check_user_option ("debug", $debug_value);
|
|
if (not $valid)
|
|
{
|
|
$option_errors++;
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# This function internally converts the value to uppercase.
|
|
#------------------------------------------------------------------------------
|
|
my $ignore_value = set_debug_size (\$debug_value);
|
|
}
|
|
next;
|
|
}
|
|
elsif (($arg eq "-q") or ($arg eq "--quiet"))
|
|
{
|
|
$quiet_value = shift @ARGV;
|
|
$valid = check_user_option ("quiet", $quiet_value);
|
|
|
|
if (not $valid)
|
|
{
|
|
$option_errors++;
|
|
}
|
|
else
|
|
{
|
|
$g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE;
|
|
}
|
|
next;
|
|
}
|
|
elsif (($arg eq "-o") or ($arg eq "--output"))
|
|
{
|
|
$outputdir_value = shift @ARGV;
|
|
$valid = check_user_option ("output", $outputdir_value);
|
|
|
|
if (not $valid)
|
|
{
|
|
$option_errors++;
|
|
}
|
|
|
|
next;
|
|
}
|
|
elsif (($arg eq "-O") or ($arg eq "--overwrite"))
|
|
{
|
|
$outputdir_value = shift @ARGV;
|
|
$valid = check_user_option ("overwrite", $outputdir_value);
|
|
|
|
if (not $valid)
|
|
{
|
|
$option_errors++;
|
|
}
|
|
|
|
next;
|
|
}
|
|
elsif (($arg eq "-hp") or ($arg eq "--highlight-percentage"))
|
|
{
|
|
$hp_value = shift @ARGV;
|
|
$valid = check_user_option ("highlight_percentage", $hp_value);
|
|
|
|
if (not $valid)
|
|
{
|
|
$option_errors++;
|
|
}
|
|
|
|
next;
|
|
}
|
|
# Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit"))
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $func_limit_value = shift @ARGV;
|
|
# Temporarily disabled $valid = check_user_option ("func_limit", $func_limit_value);
|
|
# Temporarily disabled
|
|
# Temporarily disabled if (not $valid)
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $option_errors++;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled
|
|
# Temporarily disabled next;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree"))
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $calltree_value = shift @ARGV;
|
|
# Temporarily disabled $valid = check_user_option ("calltree", $calltree_value);
|
|
# Temporarily disabled
|
|
# Temporarily disabled if (not $valid)
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $option_errors++;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled
|
|
# Temporarily disabled next;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage"))
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $tp_value = shift @ARGV;
|
|
# Temporarily disabled $valid = check_user_option ("threshold_percentage", $tp_value);
|
|
# Temporarily disabled
|
|
# Temporarily disabled if (not $valid)
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $option_errors++;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled
|
|
# Temporarily disabled next;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics"))
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $default_metrics_value = shift @ARGV;
|
|
# Temporarily disabled $valid = check_user_option ("default_metrics", $default_metrics_value);
|
|
# Temporarily disabled
|
|
# Temporarily disabled if (not $valid)
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $option_errors++;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled
|
|
# Temporarily disabled next;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics"))
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $ignore_metrics_value = shift @ARGV;
|
|
# Temporarily disabled $valid = check_user_option ("ignore_metrics", $ignore_metrics_value);
|
|
# Temporarily disabled
|
|
# Temporarily disabled if (not $valid)
|
|
# Temporarily disabled {
|
|
# Temporarily disabled $option_errors++;
|
|
# Temporarily disabled }
|
|
# Temporarily disabled
|
|
# Temporarily disabled next;
|
|
# Temporarily disabled }
|
|
else
|
|
{
|
|
|
|
#------------------------------------------------------------------------------
|
|
# When we get to this part of the code it means that the current command line
|
|
# argument is not a known option.
|
|
#
|
|
# We check if it is the name of an experiment directory and if so, add it to
|
|
# the list with directories to use.
|
|
#
|
|
# If not, print an error message and increment the error variable because this
|
|
# is clearly something that is not right.
|
|
#-------------------------------------------------------------------------------
|
|
|
|
if ($arg =~ /^\-.*/)
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# It is an option, but not a supported one. Print a message and increment
|
|
# the error count.
|
|
#-------------------------------------------------------------------------------
|
|
$message = "option $arg is not a known option";
|
|
push (@g_user_input_errors, $message);
|
|
|
|
$option_errors++;
|
|
}
|
|
else
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# Other than options, the input has to consist of at least one directory name.
|
|
# First remove any trailing slashes (/) and then check if the name is valid.
|
|
#-------------------------------------------------------------------------------
|
|
$arg =~ s/\/*\/$//;
|
|
if ($arg =~ /.+\.er$/)
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# It is the name of an experiment directory and is added to the list.
|
|
#-------------------------------------------------------------------------------
|
|
$found_exp_dir = $TRUE;
|
|
push (@exp_dir_list, $arg);
|
|
}
|
|
else
|
|
{
|
|
#-------------------------------------------------------------------------------
|
|
# It is not a valid experiment directory name. Print a message and exit.
|
|
#-------------------------------------------------------------------------------
|
|
$message = "not a valid experiment directory name: $arg";
|
|
push (@g_user_input_errors, $message);
|
|
|
|
$option_errors++;
|
|
}
|
|
}
|
|
|
|
} #-- End of last else
|
|
|
|
} #-- End of while-loop
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Check if the name of the experiment directories is valid. Note that later
|
|
# we check for these directories to exist.
|
|
#-------------------------------------------------------------------------------
|
|
if (not $found_exp_dir)
|
|
{
|
|
$message = "experiment directory name(s) are either not valid, or missing";
|
|
push (@g_user_input_errors, $message);
|
|
|
|
$option_errors++;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check for fatal errors to have occurred. If so, stop execution. Otherwise,
|
|
# confirm the verbose setting.
|
|
#------------------------------------------------------------------------------
|
|
if ($option_errors > 0)
|
|
{
|
|
gp_message ("debug", $subr_name, "a total of $option_errors input errors have been found");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "no errors in the options found");
|
|
}
|
|
|
|
return ($option_errors, $found_exp_dir, \@exp_dir_list);
|
|
|
|
} #-- End of subroutine parse_and_check_user_options
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse the generated .dis files
|
|
#------------------------------------------------------------------------------
|
|
sub parse_dis_files
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($number_of_metrics_ref, $function_info_ref,
|
|
$function_address_and_index_ref, $input_string_ref,
|
|
$addressobj_index_ref) = @_;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Note that $function_address_and_index_ref is not used, but we need to pass
|
|
# in the address into generate_dis_html.
|
|
#------------------------------------------------------------------------------
|
|
my $number_of_metrics = ${ $number_of_metrics_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
my $input_string = ${ $input_string_ref };
|
|
my %addressobj_index = %{ $addressobj_index_ref };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The regex section.
|
|
#------------------------------------------------------------------------------
|
|
my $dis_filename_id_regex = 'file\.([0-9]+)\.dis';
|
|
|
|
my $filename;
|
|
my $outputdir = append_forward_slash ($input_string);
|
|
|
|
my @source_line = ();
|
|
my $source_line_ref;
|
|
|
|
my @metric = ();
|
|
my $metric_ref;
|
|
|
|
my $target_function;
|
|
|
|
gp_message ("debug", $subr_name, "building disassembly files");
|
|
gp_message ("debug", $subr_name, "outputdir = $outputdir");
|
|
|
|
while (glob ($outputdir.'*.dis'))
|
|
{
|
|
gp_message ("debug", $subr_name, "processing disassembly file: $_");
|
|
|
|
my $base_name = get_basename ($_);
|
|
|
|
if ($base_name =~ /$dis_filename_id_regex/)
|
|
{
|
|
if (defined ($1))
|
|
{
|
|
gp_message ("debug", $subr_name, "processing disassembly file: $base_name $1");
|
|
if (exists ($function_info[$1]{"routine"}))
|
|
{
|
|
$target_function = $function_info[$1]{"routine"};
|
|
gp_message ("debug", $subr_name, "processing disassembly file: $base_name target_function = $target_function");
|
|
}
|
|
if (exists ($g_function_tag_id{$target_function}))
|
|
{
|
|
gp_message ("debug", $subr_name, "target_function = $target_function ftag = $g_function_tag_id{$target_function}");
|
|
}
|
|
else
|
|
{
|
|
my $msg = "no function tag found for $target_function";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "processing disassembly file: $base_name unknown id");
|
|
}
|
|
}
|
|
|
|
$filename = $_;
|
|
gp_message ("verbose", $subr_name, " Processing disassembly file $filename");
|
|
($source_line_ref, $metric_ref) = generate_dis_html (
|
|
\$target_function,
|
|
\$number_of_metrics,
|
|
$function_info_ref,
|
|
$function_address_and_index_ref,
|
|
\$outputdir,
|
|
\$filename,
|
|
\@source_line,
|
|
\@metric,
|
|
\%addressobj_index);
|
|
|
|
@source_line = @{ $source_line_ref };
|
|
@metric = @{ $metric_ref };
|
|
}
|
|
|
|
return (0)
|
|
|
|
} #-- End of subroutine parse_dis_files
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse the .src.txt files
|
|
#------------------------------------------------------------------------------
|
|
sub parse_source_files
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($number_of_metrics_ref, $function_info_ref, $outputdir_ref) = @_;
|
|
|
|
my $number_of_metrics = ${ $number_of_metrics_ref };
|
|
my $outputdir = ${ $outputdir_ref };
|
|
my $ignore_value;
|
|
|
|
my $outputdir_with_slash = append_forward_slash ($outputdir);
|
|
|
|
gp_message ("verbose", $subr_name, "building source files");
|
|
|
|
while (glob ($outputdir_with_slash.'*.src.txt'))
|
|
{
|
|
gp_message ("verbose", $subr_name, " Processing source file: $_");
|
|
gp_message ("debug", $subr_name, "processing source file: $_");
|
|
|
|
my $found_target = process_source (
|
|
$number_of_metrics,
|
|
$function_info_ref,
|
|
$outputdir_with_slash,
|
|
$_);
|
|
|
|
if (not $found_target)
|
|
{
|
|
gp_message ("debug", $subr_name, "target function not found");
|
|
}
|
|
}
|
|
|
|
} #-- End of subroutine parse_source_files
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Routine to prepend \\ to selected symbols.
|
|
#------------------------------------------------------------------------------
|
|
sub prepend_backslashes
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($target_string) = @_;
|
|
|
|
gp_message ("debug", $subr_name, "target_string on entry = $target_string");
|
|
|
|
$target_string =~ s/\(/\\\(/g;
|
|
$target_string =~ s/\)/\\\)/g;
|
|
$target_string =~ s/\+/\\\+/g;
|
|
$target_string =~ s/\[/\\\[/g;
|
|
$target_string =~ s/\]/\\\]/g;
|
|
$target_string =~ s/\*/\\\*/g;
|
|
$target_string =~ s/\./\\\./g;
|
|
$target_string =~ s/\$/\\\$/g;
|
|
$target_string =~ s/\^/\\\^/g;
|
|
$target_string =~ s/\#/\\\#/g;
|
|
|
|
gp_message ("debug", $subr_name, "target_string on return = $target_string");
|
|
|
|
return ($target_string);
|
|
|
|
} #-- End of subroutine prepend_backslashes
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub preprocess_function_files
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($metric_description_ref, $script_pc_metrics, $input_string, $sort_fields_ref) = @_;
|
|
|
|
my $outputdir = append_forward_slash ($input_string);
|
|
my @sort_fields = @{ $sort_fields_ref };
|
|
|
|
my $error_code;
|
|
my $cmd_output;
|
|
my $re;
|
|
|
|
# TBD $outputdir .= "/";
|
|
|
|
gp_message ("debug", $subr_name, "enter subroutine");
|
|
|
|
my %metric_description = %{ $metric_description_ref };
|
|
|
|
for my $m (keys %metric_description)
|
|
{
|
|
gp_message ("debug", $subr_name, "metric_description{$m} = $metric_description{$m}");
|
|
}
|
|
|
|
$re = name_regex ($metric_description_ref, $script_pc_metrics, "functions", $outputdir."functions.sort.func-PC");
|
|
($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."functions.sort.func-PC.name-regex");
|
|
if ($error_code != 0 )
|
|
{
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
|
|
for my $field (@sort_fields)
|
|
{
|
|
$re = name_regex ($metric_description_ref, $script_pc_metrics, $field, $outputdir."$field.sort.func-PC");
|
|
($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."$field.sort.func-PC.name-regex");
|
|
if ($error_code != 0 )
|
|
{
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
}
|
|
|
|
$re = name_regex ($metric_description_ref, $script_pc_metrics, "calls", $outputdir."calls.sort.func-PC");
|
|
($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calls.sort.func-PC.name-regex");
|
|
if ($error_code != 0 )
|
|
{
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
|
|
if ($g_user_settings{"calltree"}{"current_value"} eq "on")
|
|
{
|
|
$re = name_regex ($metric_description_ref, $script_pc_metrics, "calltree", $outputdir."calltree.sort.func-PC");
|
|
($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calltree.sort.func-PC.name-regex");
|
|
if ($error_code != 0 )
|
|
{
|
|
gp_message ("abort", $subr_name, "execution terminated");
|
|
}
|
|
}
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine preprocess_function_files
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Print the help overview
|
|
#-------------------------------------------------------------------------------
|
|
sub print_help_info
|
|
{
|
|
print
|
|
#-------Marker line - do not go beyond this line ------------------------------
|
|
"Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)\n".
|
|
"\n".
|
|
"Process one or more experiments to generate a directory containing the\n" .
|
|
"index.html file that may be used to browse the experiment data.\n".
|
|
"\n".
|
|
"Options:\n".
|
|
"\n".
|
|
" --help print usage information and exit.\n".
|
|
" --version print the version number and exit.\n".
|
|
" --verbose {on|off} enable/disable verbose mode that shows diagnostic\n" .
|
|
" messages about the processing of the data; default\n" .
|
|
" is off.\n".
|
|
#-------Marker line - do not go beyond this line ------------------------------
|
|
" -d, --debug {on|s|m|l|xl|off} control the printing of run time information\n" .
|
|
" to assist with troubleshooting, or further\n" .
|
|
" development of this tool; on gives a modest amount\n" .
|
|
" of information; s, m, l, or xl gives an increasing\n" .
|
|
" amount of information and off disables the printing\n" .
|
|
" of debug information; note that currently on, s, m,\n" .
|
|
" and l are equivalent; this is expected to change in\n" .
|
|
" future updates; default is off.\n" .
|
|
#-------Marker line - do not go beyond this line ------------------------------
|
|
" -hp, ----highlight-percentage <value> a percentage value in the interval\n" .
|
|
" [0,100] to select and color code source\n" .
|
|
" lines as well as instructions that are\n" .
|
|
" within this percentage of the maximum\n" .
|
|
" metric value(s); a value of zero (-hp 0)\n" .
|
|
" disables this feature; the default is 90.\n".
|
|
#-------Marker line - do not go beyond this line ------------------------------
|
|
" -o, --output <dir-name> use <dir-name> to store the results in; the\n" .
|
|
" default name is ./display.<n>.html with <n> the\n" .
|
|
" first positive integer number not in use; an\n" .
|
|
" existing directory is not overwritten.\n".
|
|
#-------Marker line - do not go beyond this line ------------------------------
|
|
" -O, --overwrite <dir-name> use <dir-name> to store the results in and\n" .
|
|
" overwrite any existing directory with the\n" .
|
|
" same name; make sure that umask is set to the\n" .
|
|
" correct access permissions.\n" .
|
|
#-------Marker line - do not go beyond this line ------------------------------
|
|
" -q, --quiet {on|off} disable/allow the display of all warning, debug and\n" .
|
|
" verbose messages; if set to on, the settings for\n" .
|
|
" verbose, warnings and debug are ignored; default\n" .
|
|
" is off.\n".
|
|
#-------Marker line - do not go beyond this line ------------------------------
|
|
" -w, --warnings {on|off} enable/disable run time warning messages;\n" .
|
|
" default is on.\n".
|
|
"\n".
|
|
# Temmporarily disabled " -fl, --func-limit <limit> impose a limit on the number of functions processed;\n".
|
|
# Temmporarily disabled " this is an integer number; set to 0 to process all\n".
|
|
# Temmporarily disabled " functions; the default value is 100.\n".
|
|
# Temmporarily disabled "\n".
|
|
# Temmporarily disabled " -ct, --calltree {on|off} enable or disable an html page with a call tree linked\n".
|
|
# Temmporarily disabled " from the bottom of the first page; default is off.\n".
|
|
# Temmporarily disabled "\n".
|
|
# Temmporarily disabled " -tp, --threshold-percentage <percentage> provide a percentage of metric accountability; the\n".
|
|
# Temmporarily disabled " inclusion of functions for each metric will take\n".
|
|
# Temmporarily disabled " place in sort order until the percentage has been\n".
|
|
# Temmporarily disabled " reached.\n".
|
|
# Temmporarily disabled "\n".
|
|
# Temmporarily disabled " -dm, --default-metrics {on|off} enable or disable automatic selection of metrics\n".
|
|
# Temmporarily disabled " and use a default set of metrics; the default is off.\n".
|
|
# Temmporarily disabled "\n".
|
|
# Temmporarily disabled " -im, --ignore-metrics <metric-list> ignore the metrics from <metric-list>.\n".
|
|
# Temmporarily disabled "\n".
|
|
# Temmporarily disabled "Environment:\n".
|
|
# Temmporarily disabled "\n".
|
|
# Temmporarily disabled "The options can be set in a configuration file called .gp-display-html.rc. This\n".
|
|
# Temmporarily disabled "file needs to be either in the current directory, or in the home directory of the user.\n".
|
|
# Temmporarily disabled "The long name of the option without the leading dashes is supported. For example calltree\n".
|
|
# Temmporarily disabled "to enable or disable the call tree. Note that some options take a value. In case the same option\n".
|
|
# Temmporarily disabled "occurs multiple times in this file, only the last setting encountered is preserved.\n".
|
|
# Temmporarily disabled "\n".
|
|
"Documentation:\n".
|
|
"\n".
|
|
"A getting started guide for gprofng is maintained as a Texinfo manual.\n" .
|
|
"If the info and gprofng programs are properly installed at your site,\n" .
|
|
"the command \"info gprofng\" should give you access to this document.\n".
|
|
"\n".
|
|
"See also:\n".
|
|
"\n".
|
|
"gprofng(1), gp-archive(1), gp-collect-app(1), gp-display-src(1), " .
|
|
"gp-display-text(1)\n";
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine print_help_info
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Print the meta data for each experiment directory.
|
|
#-------------------------------------------------------------------------------
|
|
sub print_meta_data_experiments
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($mode) = @_;
|
|
|
|
for my $exp (sort keys %g_exp_dir_meta_data)
|
|
{
|
|
for my $meta (sort keys %{$g_exp_dir_meta_data{$exp}})
|
|
{
|
|
gp_message ($mode, $subr_name, "$exp => $meta = $g_exp_dir_meta_data{$exp}{$meta}");
|
|
}
|
|
}
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine print_meta_data_experiments
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Brute force subroutine that prints the contents of a structure with function
|
|
# level information. This version is for a top level array structure,
|
|
# followed by a hash.
|
|
#------------------------------------------------------------------------------
|
|
sub print_metric_function_array
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($metric, $struct_type_name, $target_structure_ref) = @_;
|
|
|
|
my @target_structure = @{$target_structure_ref};
|
|
|
|
gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:");
|
|
|
|
for my $fields (sort keys @target_structure)
|
|
{
|
|
for my $elems (sort keys % {$target_structure[$fields]})
|
|
{
|
|
my $msg = $struct_type_name."{$metric}[$fields]{$elems} = ";
|
|
$msg .= $target_structure[$fields]{$elems};
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine print_metric_function_array
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Brute force subroutine that prints the contents of a structure with function
|
|
# level information. This version is for a top level hash structure. The
|
|
# next level may be another hash, or an array.
|
|
#------------------------------------------------------------------------------
|
|
sub print_metric_function_hash
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($sub_struct_type, $metric, $struct_type_name, $target_structure_ref) = @_;
|
|
|
|
my %target_structure = %{$target_structure_ref};
|
|
|
|
gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:");
|
|
|
|
for my $fields (sort keys %target_structure)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "metric = $metric fields = $fields");
|
|
if ($sub_struct_type eq "hash_hash")
|
|
{
|
|
for my $elems (sort keys %{$target_structure{$fields}})
|
|
{
|
|
my $txt = $struct_type_name."{$metric}{$fields}{$elems} = ";
|
|
$txt .= $target_structure{$fields}{$elems};
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
}
|
|
}
|
|
elsif ($sub_struct_type eq "hash_array")
|
|
{
|
|
my $values = "";
|
|
for my $elems (sort keys @{$target_structure{$fields}})
|
|
{
|
|
$values .= "$target_structure{$fields}[$elems] ";
|
|
}
|
|
gp_message ("debugXL", $subr_name, $struct_type_name."{$metric}{$fields} = $values");
|
|
}
|
|
else
|
|
{
|
|
my $msg = "sub-structure type '$sub_struct_type' is not supported";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine print_metric_function_hash
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the opening message.
|
|
#------------------------------------------------------------------------------
|
|
sub print_opening_message
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
#------------------------------------------------------------------------------
|
|
# Since the second argument is an array, we pass it in by reference. The
|
|
# alternative is to make it the last argument.
|
|
#------------------------------------------------------------------------------
|
|
my ($outputdir, $exp_dir_list_ref, $time_percentage_multiplier) = @_;
|
|
|
|
my @exp_dir_list = @{$exp_dir_list_ref};
|
|
|
|
my $msg;
|
|
my $no_of_dirs = scalar (@exp_dir_list);
|
|
#------------------------------------------------------------------------------
|
|
# Build a comma separated list with all directory names. If there is only one
|
|
# entry, the leading comma will not be inserted.
|
|
#------------------------------------------------------------------------------
|
|
my $dir_list = join (", ", @exp_dir_list);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If there are at least two entries, find the last comma and replace it by
|
|
# " and". Note that we know there is at least one comma, so the value
|
|
# returned by rindex () cannot be -1.
|
|
#------------------------------------------------------------------------------
|
|
if ($no_of_dirs > 1)
|
|
{
|
|
my $last_comma = rindex ($dir_list, ",");
|
|
my $ignore_value = substr ($dir_list, $last_comma, 1, " and");
|
|
}
|
|
$msg = "start $tool_name, generating directory $outputdir from $dir_list";
|
|
|
|
gp_message ("verbose", $subr_name, $msg);
|
|
|
|
if ($time_percentage_multiplier < 1.0)
|
|
{
|
|
$msg = "Handle at least ";
|
|
}
|
|
else
|
|
{
|
|
$msg = "Handle ";
|
|
}
|
|
|
|
$msg .= ($time_percentage_multiplier*100.0)."% of the time";
|
|
|
|
gp_message ("verbose", $subr_name, $msg);
|
|
|
|
} #-- End of subroutine print_opening_message
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD.
|
|
#------------------------------------------------------------------------------
|
|
sub print_program_header
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($mode, $tool_name, $binutils_version) = @_;
|
|
|
|
my $header_limit = 60;
|
|
my $dashes = "-";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the dashed line
|
|
#------------------------------------------------------------------------------
|
|
for (2 .. $header_limit)
|
|
{
|
|
$dashes .= "-";
|
|
}
|
|
|
|
gp_message ($mode, $subr_name, $dashes);
|
|
gp_message ($mode, $subr_name, "Tool name: $tool_name");
|
|
gp_message ($mode, $subr_name, "Version : $binutils_version");
|
|
gp_message ($mode, $subr_name, "Date : " . localtime ());
|
|
gp_message ($mode, $subr_name, $dashes);
|
|
|
|
} #-- End of subroutine print_program_header
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print a comment string, followed by the values of the options. The list
|
|
# with the keywords is sorted alphabetically.
|
|
#
|
|
# The value stored in $mode is passed on to gp_message (). The intended use
|
|
# for this is to call this function in verbose and/or debug mode.
|
|
#
|
|
# The comment string is converted to uppercase.
|
|
#
|
|
# In case the length of the comment exceeds the length of the dashed line,
|
|
# the comment line is allowed to stick out to the right.
|
|
#
|
|
# If the length of the comment is less than the dashed line, it is centered
|
|
# relative to the # length of the dashed line.
|
|
|
|
# If the length of the comment and this line do not divide, an extra space is
|
|
# added to the left of the comment.
|
|
#
|
|
# For example, if the comment is 55 long, there are 5 spaces to be distributed.
|
|
# There will be 3 spaces, followed by the comment.
|
|
#------------------------------------------------------------------------------
|
|
sub print_table_user_settings
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($mode, $comment) = @_;
|
|
|
|
my $leftover;
|
|
my $padding;
|
|
|
|
my $keyword;
|
|
my $user_option;
|
|
my $defined;
|
|
my $value;
|
|
my $data_type;
|
|
|
|
my $HEADER_LIMIT = 60;
|
|
my $header = sprintf ("%-20s %-9s %8s %s", "keyword", "option", "user set", "value");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the dashed line
|
|
#------------------------------------------------------------------------------
|
|
my $dashes = "-";
|
|
for (2 .. $HEADER_LIMIT)
|
|
{
|
|
$dashes .= "-";
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Determine the padding needed to the left of the comment.
|
|
#------------------------------------------------------------------------------
|
|
my $length_comment = length ($comment);
|
|
|
|
$leftover = $length_comment%2;
|
|
|
|
if ($length_comment <= ($HEADER_LIMIT-2))
|
|
{
|
|
$padding = ($HEADER_LIMIT - $length_comment + $leftover)/2;
|
|
}
|
|
else
|
|
{
|
|
$padding = 0;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the first blank part of the line.
|
|
#------------------------------------------------------------------------------
|
|
my $blank_line = "";
|
|
for (1 .. $padding)
|
|
{
|
|
$blank_line .= " ";
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add the comment line with the first letter in uppercase.
|
|
#------------------------------------------------------------------------------
|
|
my $final_comment = $blank_line.ucfirst ($comment);
|
|
|
|
gp_message ($mode, $subr_name, $dashes);
|
|
gp_message ($mode, $subr_name, $final_comment);
|
|
gp_message ($mode, $subr_name, $dashes);
|
|
gp_message ($mode, $subr_name, $header);
|
|
gp_message ($mode, $subr_name, $dashes);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print a line for each option. The list is sorted alphabetically.
|
|
#------------------------------------------------------------------------------
|
|
for my $rc_keyword (sort keys %g_user_settings)
|
|
{
|
|
$keyword = $rc_keyword;
|
|
$user_option = $g_user_settings{$rc_keyword}{"option"};
|
|
$defined = ($g_user_settings{$rc_keyword}{"defined"} ? "set" : "not set");
|
|
$data_type = $g_user_settings{$rc_keyword}{"data_type"};
|
|
|
|
if (defined ($g_user_settings{$rc_keyword}{"current_value"}))
|
|
{
|
|
$value = $g_user_settings{$rc_keyword}{"current_value"};
|
|
if ($data_type eq "boolean")
|
|
{
|
|
$value = $value ? "on" : "off";
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$value = "undefined";
|
|
}
|
|
|
|
my $print_line = sprintf ("%-20s %-9s %8s %s", $keyword, $user_option, $defined, $value);
|
|
|
|
gp_message ($mode, $subr_name, $print_line);
|
|
}
|
|
} #-- End of subroutine print_table_user_settings
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Dump the contents of nested hash "g_user_settings". Some simple formatting
|
|
# is applied to make it easier to distinguish the various values.
|
|
#------------------------------------------------------------------------------
|
|
sub print_user_settings
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($mode, $comment) = @_;
|
|
|
|
my $keyword_value_pair;
|
|
|
|
gp_message ($mode, $subr_name, $comment);
|
|
|
|
for my $rc_keyword (keys %g_user_settings)
|
|
{
|
|
my $print_line = sprintf ("%-20s =>", $rc_keyword);
|
|
for my $fields (sort keys %{ $g_user_settings{$rc_keyword} })
|
|
{
|
|
if (defined ($g_user_settings{$rc_keyword}{$fields}))
|
|
{
|
|
$keyword_value_pair = $fields." = ".$g_user_settings{$rc_keyword}{$fields};
|
|
}
|
|
else
|
|
{
|
|
$keyword_value_pair = $fields." = ". "undefined";
|
|
}
|
|
$print_line = join (" ", $print_line, $keyword_value_pair);
|
|
}
|
|
gp_message ($mode, $subr_name, $print_line);
|
|
}
|
|
} #-- End of subroutine print_user_settings
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the version number and license information.
|
|
#------------------------------------------------------------------------------
|
|
sub print_version_info
|
|
{
|
|
print "$version_info\n";
|
|
print "Copyright (C) 2023 Free Software Foundation, Inc.\n";
|
|
print "License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>.\n";
|
|
print "This is free software: you are free to change and redistribute it.\n";
|
|
print "There is NO WARRANTY, to the extent permitted by law.\n";
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine print_version_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process the call tree input data and generate HTML output.
|
|
#------------------------------------------------------------------------------
|
|
sub process_calltree
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref,
|
|
$input_string) = @_;
|
|
|
|
my @function_info = @{ $function_info_ref };
|
|
my %function_address_info = %{ $function_address_info_ref };
|
|
my %addressobjtextm = %{ $addressobjtextm_ref };
|
|
|
|
my $outputdir = append_forward_slash ($input_string);
|
|
|
|
my @call_tree_data = ();
|
|
|
|
my $LANG = $g_locale_settings{"LANG"};
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
|
|
my $infile = $outputdir . "calltree";
|
|
my $outfile = $outputdir . "calltree.html";
|
|
|
|
open (CALL_TREE_IN, "<", $infile)
|
|
or die ("Not able to open calltree file $infile for reading - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $infile for reading");
|
|
|
|
open (CALL_TREE_OUT, ">", $outfile)
|
|
or die ("Not able to open $outfile for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile for writing");
|
|
|
|
gp_message ("debug", $subr_name, "building calltree file $outfile");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The directory name is potentially used below, but since it is a constant,
|
|
# we get it here and only once.
|
|
#------------------------------------------------------------------------------
|
|
# my ($ignore_file_name, $directory_name, $ignore_suffix) = fileparse ($infile,"");
|
|
# gp_message ("debug", $subr_name, "directory_name = $directory_name");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate some of the structures used in the HTML output.
|
|
#------------------------------------------------------------------------------
|
|
my $file_title = "Call Tree overview";
|
|
my $html_header = ${ create_html_header (\$file_title) };
|
|
my $html_home_right = ${ generate_home_link ("right") };
|
|
|
|
my $page_title = "Call Tree View";
|
|
my $size_text = "h2";
|
|
my $position_text = "center";
|
|
my $html_title_header = ${ generate_a_header (
|
|
\$page_title,
|
|
\$size_text,
|
|
\$position_text) };
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Get the acknowledgement, return to main link, and final html statements.
|
|
#-------------------------------------------------------------------------------
|
|
my $html_home_left = ${ generate_home_link ("left") };
|
|
my $html_acknowledgement = ${ create_html_credits () };
|
|
my $html_end = ${ terminate_html_document () };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read all of the file into array with the name call_tree_data.
|
|
#------------------------------------------------------------------------------
|
|
chomp (@call_tree_data = <CALL_TREE_IN>);
|
|
close (CALL_TREE_IN);
|
|
|
|
#------------------------------------------------------------------------------
|
|
#------------------------------------------------------------------------------
|
|
# Process the data here and generate the HTML lines.
|
|
#------------------------------------------------------------------------------
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the top part of the HTML file.
|
|
#------------------------------------------------------------------------------
|
|
print CALL_TREE_OUT $html_header;
|
|
print CALL_TREE_OUT $html_home_right;
|
|
print CALL_TREE_OUT $html_title_header;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Print the generated HTML structures here.
|
|
#-------------------------------------------------------------------------------
|
|
## print CALL_TREE_OUT "$_" for @whatever;
|
|
## print CALL_TREE_OUT "<pre>\n";
|
|
## print CALL_TREE_OUT "$_\n" for @whatever2;
|
|
## print CALL_TREE_OUT "</pre>\n";
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Print the last part of the HTML file.
|
|
#-------------------------------------------------------------------------------
|
|
print CALL_TREE_OUT $html_home_left;
|
|
print CALL_TREE_OUT "<br>\n";
|
|
print CALL_TREE_OUT $html_acknowledgement;
|
|
print CALL_TREE_OUT $html_end;
|
|
|
|
close (CALL_TREE_OUT);
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine process_calltree
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Process the generated experiment info file(s).
|
|
#-------------------------------------------------------------------------------
|
|
sub process_experiment_info
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($experiment_data_ref) = @_;
|
|
|
|
my @exp_info;
|
|
my @experiment_data = @{ $experiment_data_ref };
|
|
|
|
my $exp_id;
|
|
my $exp_name;
|
|
my $exp_data_file;
|
|
my $input_line;
|
|
my $target_cmd;
|
|
my $hostname ;
|
|
my $OS;
|
|
my $page_size;
|
|
my $architecture;
|
|
my $start_date;
|
|
my $end_experiment;
|
|
my $data_collection_duration;
|
|
my $total_thread_time;
|
|
my $user_cpu_time;
|
|
my $user_cpu_percentage;
|
|
my $system_cpu_time;
|
|
my $system_cpu_percentage;
|
|
my $sleep_time;
|
|
my $sleep_percentage;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Define the regular expressions used to capture the info.
|
|
#-------------------------------------------------------------------------------
|
|
# Target command (64-bit): './../bindir/mxv-pthreads.exe -m 3000 -n 2000 -t 2'
|
|
|
|
my $target_cmd_regex = '\s*Target command\s+(\(.+\)):\s+\'(.+)\'';
|
|
|
|
# Host `ruudvan-vm-haswell-2-20210609', OS `Linux 5.4.17-2102.202.5.el8uek.x86_64', page size 4096, architecture `x86_64'
|
|
|
|
my $host_system_regex = '\s*Host\s+\`(.+)\',\s+OS\s+\`(.+)\',\s+page size\s+(\d+),\s+architecture\s+\`(.+)\'';
|
|
|
|
# Experiment started Mon Aug 30 13:03:20 2021
|
|
|
|
my $start_date_regex = '\s*Experiment started\s+(.+)';
|
|
|
|
# Experiment Ended: 1.812441219
|
|
|
|
my $end_experiment_regex = '\s*Experiment Ended:\s+(.+)';
|
|
|
|
# Data Collection Duration: 1.812441219
|
|
|
|
my $data_collection_duration_regex = '\s*Data Collection Duration:\s+(.+)';
|
|
|
|
# Total Thread Time (sec.): 1.812
|
|
|
|
my $total_thread_time_regex = '\s*Total Thread Time (sec.):\s+(.+)';
|
|
|
|
# User CPU: 1.685 ( 95.0%)
|
|
|
|
my $user_cpu_regex = '\s*User CPU:\s+(.+)\s+\(\s*(.+)\)';
|
|
|
|
# System CPU: 0.088 ( 5.0%)
|
|
|
|
my $system_cpu_regex = '\s*System CPU:\s+(.+)\s+\(\s*(.+)\)';
|
|
|
|
# Sleep: 0. ( 0. %)
|
|
|
|
my $sleep_regex = '\s*Sleep:\s+(.+)\s+\(\s*(.+)\)';
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Scan the experiment data and select the info of interest.
|
|
#-------------------------------------------------------------------------------
|
|
for my $i (sort keys @experiment_data)
|
|
{
|
|
$exp_id = $experiment_data[$i]{"exp_id"};
|
|
$exp_name = $experiment_data[$i]{"exp_name_full"};
|
|
$exp_data_file = $experiment_data[$i]{"exp_data_file"};
|
|
|
|
my $msg = "exp_id = $exp_id name = $exp_name file = $exp_data_file";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
|
|
open (EXPERIMENT_INFO, "<", $exp_data_file)
|
|
or die ("$subr_name - unable to open file $exp_data_file for reading '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $exp_data_file for reading");
|
|
|
|
chomp (@exp_info = <EXPERIMENT_INFO>);
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Process the info for the current experiment.
|
|
#-------------------------------------------------------------------------------
|
|
for my $line (0 .. $#exp_info)
|
|
{
|
|
$input_line = $exp_info[$line];
|
|
|
|
my $msg = "exp_id = $exp_id: input_line = $input_line";
|
|
gp_message ("debugM", $subr_name, $msg);
|
|
|
|
if ($input_line =~ /$target_cmd_regex/)
|
|
{
|
|
$target_cmd = $2;
|
|
gp_message ("debugM", $subr_name, "$exp_id => $target_cmd");
|
|
$experiment_data[$i]{"target_cmd"} = $target_cmd;
|
|
}
|
|
elsif ($input_line =~ /$host_system_regex/)
|
|
{
|
|
$hostname = $1;
|
|
$OS = $2;
|
|
$page_size = $3;
|
|
$architecture = $4;
|
|
gp_message ("debugM", $subr_name, "$exp_id => $hostname $OS $page_size $architecture");
|
|
$experiment_data[$i]{"hostname"} = $hostname;
|
|
$experiment_data[$i]{"OS"} = $OS;
|
|
$experiment_data[$i]{"page_size"} = $page_size;
|
|
$experiment_data[$i]{"architecture"} = $architecture;
|
|
}
|
|
elsif ($input_line =~ /$start_date_regex/)
|
|
{
|
|
$start_date = $1;
|
|
gp_message ("debugM", $subr_name, "$exp_id => $start_date");
|
|
$experiment_data[$i]{"start_date"} = $start_date;
|
|
}
|
|
elsif ($input_line =~ /$end_experiment_regex/)
|
|
{
|
|
$end_experiment = $1;
|
|
gp_message ("debugM", $subr_name, "$exp_id => $end_experiment");
|
|
$experiment_data[$i]{"end_experiment"} = $end_experiment;
|
|
}
|
|
elsif ($input_line =~ /$data_collection_duration_regex/)
|
|
{
|
|
$data_collection_duration = $1;
|
|
gp_message ("debugM", $subr_name, "$exp_id => $data_collection_duration");
|
|
$experiment_data[$i]{"data_collection_duration"} = $data_collection_duration;
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Start Label: Total
|
|
# End Label: Total
|
|
# Start Time (sec.): 0.000
|
|
# End Time (sec.): 1.812
|
|
# Duration (sec.): 1.812
|
|
# Total Thread Time (sec.): 1.812
|
|
# Average number of Threads: 1.000
|
|
#
|
|
# Process Times (sec.):
|
|
# User CPU: 1.666 ( 91.9%)
|
|
# System CPU: 0.090 ( 5.0%)
|
|
# Trap CPU: 0. ( 0. %)
|
|
# User Lock: 0. ( 0. %)
|
|
# Data Page Fault: 0. ( 0. %)
|
|
# Text Page Fault: 0. ( 0. %)
|
|
# Kernel Page Fault: 0. ( 0. %)
|
|
# Stopped: 0. ( 0. %)
|
|
# Wait CPU: 0. ( 0. %)
|
|
# Sleep: 0.056 ( 3.1%)
|
|
#------------------------------------------------------------------------------
|
|
elsif ($input_line =~ /$total_thread_time_regex/)
|
|
{
|
|
$total_thread_time = $1;
|
|
gp_message ("debugM", $subr_name, "$exp_id => $total_thread_time");
|
|
$experiment_data[$i]{"total_thread_time"} = $total_thread_time;
|
|
}
|
|
elsif ($input_line =~ /$user_cpu_regex/)
|
|
{
|
|
$user_cpu_time = $1;
|
|
$user_cpu_percentage = $2;
|
|
gp_message ("debugM", $subr_name, "$exp_id => $user_cpu_time $user_cpu_percentage");
|
|
$experiment_data[$i]{"user_cpu_time"} = $user_cpu_time . " (" . $user_cpu_percentage . ")";
|
|
$experiment_data[$i]{"user_cpu_percentage"} = $user_cpu_percentage;
|
|
}
|
|
elsif ($input_line =~ /$system_cpu_regex/)
|
|
{
|
|
$system_cpu_time = $1;
|
|
$system_cpu_percentage = $2;
|
|
gp_message ("debugM", $subr_name, "$exp_id => $system_cpu_time $system_cpu_percentage");
|
|
$experiment_data[$i]{"system_cpu_time"} = $system_cpu_time . " (" . $system_cpu_percentage . ")";
|
|
$experiment_data[$i]{"system_cpu_percentage"} = $system_cpu_percentage;
|
|
}
|
|
elsif ($input_line =~ /$sleep_regex/)
|
|
{
|
|
$sleep_time = $1;
|
|
$sleep_percentage = $2;
|
|
$experiment_data[$i]{"sleep_time"} = $sleep_time . " (" . $sleep_percentage . ")";
|
|
$experiment_data[$i]{"sleep_percentage"} = $sleep_percentage;
|
|
|
|
my $msg = "exp_id = $exp_id => sleep_time = $sleep_time " .
|
|
"sleep_percentage = $sleep_percentage";
|
|
gp_message ("debugM", $subr_name, $msg);
|
|
}
|
|
}
|
|
}
|
|
|
|
for my $keys (0 .. $#experiment_data)
|
|
{
|
|
for my $fields (sort keys %{ $experiment_data[$keys] })
|
|
{
|
|
my $msg = "experiment_data[$keys]{$fields} = " .
|
|
$experiment_data[$keys]{$fields};
|
|
gp_message ("debugM", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
return (\@experiment_data);
|
|
|
|
} #-- End of subroutine process_experiment_info
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub process_function_files
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier,
|
|
$summary_metrics, $process_all_functions, $elf_loadobjects_found,
|
|
$outputdir, $sort_fields_ref, $function_info_ref,
|
|
$function_address_and_index_ref, $LINUX_vDSO_ref,
|
|
$metric_description_ref, $elf_arch, $base_va_executable,
|
|
$ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_;
|
|
|
|
my $old_fsummary;
|
|
my $total_attributed_time;
|
|
my $current_attributed_time;
|
|
my $value;
|
|
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
my %function_address_and_index = %{ $function_address_and_index_ref };
|
|
my @sort_fields = @{ $sort_fields_ref };
|
|
my %metric_description = %{ $metric_description_ref };
|
|
my %elf_rats = %{ $elf_rats_ref };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The regex section.
|
|
#
|
|
# TBD: Remove the part regarding clones. Legacy.
|
|
#------------------------------------------------------------------------------
|
|
my $replace_quote_regex = '"/\"';
|
|
my $find_clone_regex = '^(.*)(\s+--\s+cloned\s+version\s+\[)([^]]+)(\])';
|
|
|
|
my %addressobj_index = ();
|
|
my %function_address_info = ();
|
|
my $function_address_info_ref;
|
|
|
|
$outputdir = append_forward_slash ($outputdir);
|
|
|
|
my %functions_per_metric_indexes = ();
|
|
my $functions_per_metric_indexes_ref;
|
|
|
|
my %functions_per_metric_first_index = ();
|
|
my $functions_per_metric_first_index_ref;
|
|
|
|
my %routine_list = ();
|
|
my %handled_routines = ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Name cleanup needed.
|
|
#------------------------------------------------------------------------------
|
|
|
|
my $number_of_metrics;
|
|
my $expr_name;
|
|
my $routine;
|
|
my $tmp;
|
|
my $loadobj;
|
|
my $PCA;
|
|
my $address_field;
|
|
my $limit_txt;
|
|
my $n_metrics_text;
|
|
my $disfile;
|
|
my $srcfile;
|
|
my $RIN;
|
|
my $gp_listings_cmd;
|
|
my $gp_display_text_cmd;
|
|
my $ignore_value;
|
|
|
|
my $result_file = $outputdir . "gp-listings.out";
|
|
my $gp_error_file = $outputdir . "gp-listings.err";
|
|
|
|
my $convert_to_dot = $g_locale_settings{"convert_to_dot"};
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
my $length_of_string = length ($outputdir);
|
|
|
|
$expr_name = join (" ", @exp_dir_list);
|
|
|
|
gp_message ("debug", $subr_name, "expr_name = $expr_name");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Loop over the files in $outputdir.
|
|
#------------------------------------------------------------------------------
|
|
while (glob ($outputdir.'*.sort.func-PC'))
|
|
{
|
|
my $metric;
|
|
my $infile;
|
|
my $ignore_value;
|
|
my $suffix_not_used;
|
|
|
|
$infile = $_;
|
|
|
|
($metric, $ignore_value, $suffix_not_used) = fileparse ($infile, ".sort.func-PC");
|
|
|
|
gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used");
|
|
gp_message ("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-");
|
|
|
|
# Function_info creates the functions files from the PC ones
|
|
# as well as culling PC and metric information
|
|
|
|
($function_address_info_ref,
|
|
$functions_per_metric_first_index_ref,
|
|
$functions_per_metric_indexes_ref) = function_info (
|
|
$outputdir,
|
|
$infile,
|
|
$metric,
|
|
$LINUX_vDSO_ref);
|
|
|
|
@{$function_address_info{$metric}} = @{$function_address_info_ref};
|
|
%{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref};
|
|
%{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref};
|
|
|
|
$ignore_value = print_metric_function_array ($metric,
|
|
"function_address_info",
|
|
\@{$function_address_info{$metric}});
|
|
$ignore_value = print_metric_function_hash ("hash_hash", $metric,
|
|
"functions_per_metric_first_index",
|
|
\%{$functions_per_metric_first_index{$metric}});
|
|
$ignore_value = print_metric_function_hash ("hash_array", $metric,
|
|
"functions_per_metric_indexes",
|
|
\%{$functions_per_metric_indexes{$metric}});
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get header info for use in post processing er_html output
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "get_hdr_info section");
|
|
|
|
get_hdr_info ($outputdir, $outputdir."functions.sort.func");
|
|
|
|
for my $field (@sort_fields)
|
|
{
|
|
get_hdr_info ($outputdir, $outputdir."$field.sort.func");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Caller-callee
|
|
#------------------------------------------------------------------------------
|
|
get_hdr_info ($outputdir, $outputdir."calls.sort.func");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Calltree
|
|
#------------------------------------------------------------------------------
|
|
if ($g_user_settings{"calltree"}{"current_value"} eq "on")
|
|
{
|
|
get_hdr_info ($outputdir, $outputdir."calltree.sort.func");
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "process functions");
|
|
|
|
my $scriptfile = $outputdir.'gp-script';
|
|
my $script_metrics = "$summary_metrics";
|
|
my $func_limit = $g_user_settings{"func_limit"}{"current_value"};
|
|
|
|
open (SCRIPT, ">", $scriptfile)
|
|
or die ("Unable to create script file $scriptfile - '$!'");
|
|
gp_message ("debug", $subr_name, "opened script file $scriptfile for writing");
|
|
|
|
print SCRIPT "# limit $func_limit\n";
|
|
print SCRIPT "limit $func_limit\n";
|
|
print SCRIPT "# thread_select all\n";
|
|
print SCRIPT "thread_select all\n";
|
|
print SCRIPT "# metrics $script_metrics\n";
|
|
print SCRIPT "metrics $script_metrics\n";
|
|
|
|
for my $metric (@sort_fields)
|
|
{
|
|
gp_message ("debug", $subr_name, "handling $metric->$metric_description{$metric}");
|
|
|
|
$total_attributed_time = 0;
|
|
$current_attributed_time = 0;
|
|
|
|
$value = $function_address_info{$metric}[0]{"metric_value"}; # <Total>
|
|
if ($convert_to_dot)
|
|
{
|
|
$value =~ s/$decimal_separator/\./;
|
|
}
|
|
$total_attributed_time = $value;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# start at 1 - skipping <Total>
|
|
#------------------------------------------------------------------------------
|
|
for my $INDEX (1 .. $#{$function_address_info{$metric}})
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
#Looking to handle at least 99% of the time - or what the user asked for
|
|
#------------------------------------------------------------------------------
|
|
$value = $function_address_info{$metric}[$INDEX]{"metric_value"};
|
|
$routine = $function_address_info{$metric}[$INDEX]{"routine"};
|
|
|
|
gp_message ("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time");
|
|
gp_message ("debugXL", $subr_name, " (found routine $routine : value $value)");
|
|
|
|
if ($convert_to_dot)
|
|
{
|
|
$value =~ s/$decimal_separator/\./;
|
|
}
|
|
|
|
if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or
|
|
( ($total_attributed_time == 0) and ($value>0) ) or
|
|
$process_all_functions)
|
|
{
|
|
$PCA = $function_address_info{$metric}[$INDEX]{"PC Address"};
|
|
|
|
if (not exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}))
|
|
{
|
|
gp_message ("debugXL", $subr_name, "not exists: functions_per_metric_first_index{$metric}{$routine}{$PCA}");
|
|
}
|
|
if (not exists ($function_address_and_index{$routine}{$PCA}))
|
|
{
|
|
gp_message ("debugXL", $subr_name, "not exists: function_address_and_index{$routine}{$PCA}");
|
|
}
|
|
|
|
if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and
|
|
exists ($function_address_and_index{$routine}{$PCA}))
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# handled_routines now contains $RI from "first_metric" (?)
|
|
#------------------------------------------------------------------------------
|
|
$handled_routines{$function_address_and_index{$routine}{$PCA}} = 1;
|
|
my $description = ${ retrieve_metric_description (\$metric, \%metric_description) };
|
|
if ($metric_description{$metric} =~ /Exclusive Total CPU Time/)
|
|
{
|
|
$routine_list{$routine} = 1
|
|
}
|
|
|
|
gp_message ("debugXL", $subr_name, " $routine is candidate");
|
|
}
|
|
else
|
|
{
|
|
die ("internal error for metric $metric and routine $routine");
|
|
}
|
|
|
|
$current_attributed_time += $value;
|
|
}
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Sort numerically in ascending order.
|
|
#------------------------------------------------------------------------------
|
|
for my $routine_index (sort {$a <=> $b} keys %handled_routines)
|
|
{
|
|
$routine = $function_info[$routine_index]{"routine"};
|
|
gp_message ("debugXL", $subr_name, "routine_index = $routine_index routine = $routine");
|
|
next unless $routine_list{$routine};
|
|
|
|
# not used $source = $function_info[$routine_index]{"Source File"};
|
|
|
|
$function_info[$routine_index]{"srcline"} = "";
|
|
$address_field = $function_info[$routine_index]{"addressobjtext"};
|
|
|
|
## $disfile = "file\.$routine_index\.dis";
|
|
$disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"};
|
|
$srcfile = "";
|
|
$srcfile = "file\.$routine_index\.src.txt";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If the file is unknown, we can disassemble anyway and add disassembly
|
|
# to the script.
|
|
#------------------------------------------------------------------------------
|
|
print SCRIPT "# outfile $outputdir"."$disfile\n";
|
|
print SCRIPT "outfile $outputdir"."$disfile\n";
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Legacy. Not sure why this is needed, but it won't harm things. I hope.
|
|
#------------------------------------------------------------------------------
|
|
$tmp = $routine;
|
|
$tmp =~ s/$replace_quote_regex//g;
|
|
print SCRIPT "# disasm \"$tmp\" $address_field\n";
|
|
print SCRIPT "disasm \"$tmp\" $address_field\n";
|
|
if ($srcfile=~/file/)
|
|
{
|
|
print SCRIPT "# outfile $outputdir"."$srcfile\n";
|
|
print SCRIPT "outfile $outputdir"."$srcfile\n";
|
|
print SCRIPT "# source \"$tmp\" $address_field\n";
|
|
print SCRIPT "source \"$tmp\" $address_field\n";
|
|
}
|
|
|
|
if ($routine =~ /$find_clone_regex/)
|
|
{
|
|
my ($clone_routine) = $1.$2.$3.$4;
|
|
my ($clone) = $3;
|
|
}
|
|
}
|
|
close SCRIPT;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Remember the number of handled routines depends on the limit setting passed
|
|
# to er_print together with the sorting order on the metrics, which usually results
|
|
# in different routines at the top. Thus $RIN below can be greater than the limit.
|
|
#------------------------------------------------------------------------------
|
|
|
|
$RIN = scalar (keys %handled_routines);
|
|
|
|
if (!$func_limit)
|
|
{
|
|
$limit_txt = "unlimited";
|
|
}
|
|
else
|
|
{
|
|
$limit_txt = $func_limit - 1;
|
|
}
|
|
|
|
$number_of_metrics = scalar (@sort_fields);
|
|
|
|
$n_metrics_text = ($number_of_metrics == 1) ? "metric" : "metrics";
|
|
|
|
gp_message ("debugXL", $subr_name, "built function list with $RIN functions");
|
|
gp_message ("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt");
|
|
|
|
# add ELF program header offset
|
|
|
|
for my $routine_index (sort {$a <=> $b} keys %handled_routines)
|
|
{
|
|
$routine = $function_info[$routine_index]{"routine"};
|
|
$loadobj = $function_info[$routine_index]{"Load Object"};
|
|
|
|
gp_message ("debugXL", $subr_name, "routine = $routine loadobj = $loadobj elf_arch = $elf_arch");
|
|
|
|
if ($loadobj ne '')
|
|
{
|
|
# <Truncated-stack> is associated with <Total>. Its load object is <Total>
|
|
if ($loadobj eq "<Total>")
|
|
{
|
|
next;
|
|
}
|
|
# Have seen a routine called <Unknown>. Its load object is <Unknown>
|
|
if ($loadobj eq "<Unknown>")
|
|
{
|
|
next;
|
|
}
|
|
###############################################################################
|
|
## RUUD: The new approach gives a different result. Investigate this.
|
|
#
|
|
# Turns out the new code improves the result. The addresses are now correct
|
|
# and as a result, more ftag's are created later on.
|
|
###############################################################################
|
|
gp_message ("debugXL", $subr_name, "before function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}");
|
|
|
|
$function_info[$routine_index]{"addressobj"} += bigint::hex (
|
|
determine_base_va_address (
|
|
$executable_name,
|
|
$base_va_executable,
|
|
$loadobj,
|
|
$routine));
|
|
$addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index;
|
|
|
|
gp_message ("debugXL", $subr_name, "after function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}");
|
|
gp_message ("debugXL", $subr_name, "after addressobj_index{function_info[$routine_index]{addressobj}} = $addressobj_index{$function_info[$routine_index]{'addressobj'}}");
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Get the disassembly and source code output.
|
|
#------------------------------------------------------------------------------
|
|
$gp_listings_cmd = "$GP_DISPLAY_TEXT -limit $func_limit -viewmode machine " .
|
|
"-compare off -script $scriptfile $expr_name";
|
|
|
|
$gp_display_text_cmd = "$gp_listings_cmd 1> $result_file 2>> $gp_error_file";
|
|
|
|
gp_message ("debugXL", $subr_name,"gp_display_text_cmd = $gp_display_text_cmd");
|
|
|
|
gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to produce disassembly and source code output");
|
|
|
|
my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd);
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
$ignore_value = msg_display_text_failure ($gp_display_text_cmd,
|
|
$error_code,
|
|
$gp_error_file);
|
|
gp_message ("abort", "execution terminated");
|
|
}
|
|
|
|
return (\@function_info, \%function_address_info, \%addressobj_index);
|
|
|
|
} #-- End of subroutine process_function_files
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process the information found in the function overview file passed in.
|
|
#
|
|
# Example input:
|
|
#
|
|
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
|
|
# Functions sorted by metric: Exclusive Total CPU Time
|
|
#
|
|
# PC Addr. Name Excl. Excl. CPU Excl. Excl. Excl. Excl.
|
|
# Total Cycles Instructions Last-Level IPC CPI
|
|
# CPU sec. sec. Executed Cache Misses
|
|
# 1:0x00000000 <Total> 3.713 4.256 15396819712 27727992 1.577 0.634
|
|
# 2:0x000021ae mxv_core 3.532 4.116 14500538992 27527781 1.536 0.651
|
|
# 2:0x00001f7b init_data 0.070 0.084 64020034 200211 0.333 3.000
|
|
#------------------------------------------------------------------------------
|
|
sub process_function_overview
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($metric_ref, $exp_type_ref, $summary_metrics_ref, $number_of_metrics_ref,
|
|
$function_info_ref, $function_view_structure_ref, $overview_file_ref) = @_;
|
|
|
|
my $metric = ${ $metric_ref };
|
|
my $exp_type = ${ $exp_type_ref };
|
|
my $summary_metrics = ${ $summary_metrics_ref };
|
|
my $number_of_metrics = ${ $number_of_metrics_ref };
|
|
my @function_info = @{ $function_info_ref };
|
|
my %function_view_structure = %{ $function_view_structure_ref };
|
|
my $overview_file = ${ $overview_file_ref };
|
|
|
|
my $all_metrics;
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
my $length_of_block;
|
|
my $elements_in_name;
|
|
my $full_hex_address;
|
|
my $header_line;
|
|
my $hex_address;
|
|
my $html_line;
|
|
my $input_line;
|
|
my $name_regex;
|
|
my $no_of_fields;
|
|
my $metrics_length;
|
|
my $missing_digits;
|
|
my $remaining_part_header;
|
|
my $routine;
|
|
my $routine_length;
|
|
my $scan_header = $FALSE;
|
|
my $scan_function_data = $FALSE;
|
|
my $string_length;
|
|
my $total_header_lines;
|
|
|
|
my @address_field = ();
|
|
my @fields = ();
|
|
my @function_data = ();
|
|
my @function_names = ();
|
|
my @function_view_array = ();
|
|
my @function_view_modified = ();
|
|
my @header_lines = ();
|
|
my @metrics_part = ();
|
|
my @metric_values = ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The regex section.
|
|
#------------------------------------------------------------------------------
|
|
my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)';
|
|
my $total_marker_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(<Total>)\s+(.*)';
|
|
my $empty_line_regex = '^\s*$';
|
|
my $catch_all_regex = '\s*(.*)';
|
|
my $get_hex_address_regex = '(\d+):0x(\S+)';
|
|
my $get_addr_offset_regex = '^@\d+:';
|
|
my $zero_dot_at_end_regex = '[\w0-9' . $decimal_separator . ']*(0' . $decimal_separator . '$)';
|
|
my $backward_slash_regex = '\/';
|
|
|
|
#------------------------------------------------------------------------------
|
|
if (is_file_empty ($overview_file))
|
|
{
|
|
gp_message ("error", $subr_name, "assertion error: file $overview_file is empty");
|
|
}
|
|
|
|
open (FUNC_OVERVIEW, "<", $overview_file)
|
|
or die ("$subr_name - unable to open file $overview_file for reading '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $overview_file for reading");
|
|
|
|
gp_message ("debug", $subr_name, "processing file for exp_type = $exp_type");
|
|
|
|
gp_message ("debugM", $subr_name, "header_name_regex = $header_name_regex");
|
|
gp_message ("debugM", $subr_name, "total_marker_regex = $total_marker_regex");
|
|
gp_message ("debugM", $subr_name, "empty_line_regex = $empty_line_regex");
|
|
gp_message ("debugM", $subr_name, "catch_all_regex = $catch_all_regex");
|
|
gp_message ("debugM", $subr_name, "get_hex_address_regex = $get_hex_address_regex");
|
|
gp_message ("debugM", $subr_name, "get_addr_offset_regex = $get_addr_offset_regex");
|
|
gp_message ("debugM", $subr_name, "zero_dot_at_end_regex = $zero_dot_at_end_regex");
|
|
gp_message ("debugM", $subr_name, "backward_slash_regex = $backward_slash_regex");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read the input file into memory.
|
|
#------------------------------------------------------------------------------
|
|
chomp (@function_data = <FUNC_OVERVIEW>);
|
|
gp_message ("debug", $subr_name, "read all of file $overview_file into memory");
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Parse the function view info and store the data.
|
|
#-------------------------------------------------------------------------------
|
|
my $max_header_length = 0;
|
|
my $max_metrics_length = 0;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Loop over all the lines. Extract the header, metric values, function names,
|
|
# and the addresses.
|
|
#
|
|
# This is also where the maximum lengths for the header and metric lines are
|
|
# computed. This is used to get the correct alignment in the HTML output.
|
|
#------------------------------------------------------------------------------
|
|
for (my $line = 0; $line <= $#function_data; $line++)
|
|
{
|
|
$input_line = $function_data[$line];
|
|
gp_message ("debugXL", $subr_name, "input_line = $input_line");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The table header is assumed to start at the line that has "Name" in it.
|
|
# The header ends when we see the function name "<Total>".
|
|
#------------------------------------------------------------------------------
|
|
if ($input_line =~ /$header_name_regex/)
|
|
{
|
|
$scan_header = $TRUE;
|
|
}
|
|
elsif ($input_line =~ /$total_marker_regex/)
|
|
{
|
|
$scan_header = $FALSE;
|
|
$scan_function_data = $TRUE;
|
|
}
|
|
|
|
if ($scan_header)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# This group is only defined for the first line of the header and $4 contains
|
|
# the remaining part of the line after "Name", without the leading spaces.
|
|
#------------------------------------------------------------------------------
|
|
if (defined ($4))
|
|
{
|
|
$remaining_part_header = $4;
|
|
my $msg = "remaining_part_header = $remaining_part_header";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Determine the maximum length of the header. This needs to be done before
|
|
# the HTML controls are added.
|
|
#------------------------------------------------------------------------------
|
|
my $header_length = length ($remaining_part_header);
|
|
$max_header_length = max ($max_header_length, $header_length);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD Should change this and not yet include html in header_lines
|
|
#------------------------------------------------------------------------------
|
|
$html_line = "<b>" . $remaining_part_header . "</b>";
|
|
|
|
push (@header_lines, $html_line);
|
|
|
|
gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length");
|
|
gp_message ("debugXL", $subr_name, "html_line = $html_line");
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Captures the subsequent header lines. Assume they exist.
|
|
#------------------------------------------------------------------------------
|
|
elsif ($input_line =~ /$catch_all_regex/)
|
|
{
|
|
$header_line = $1;
|
|
gp_message ("debugXL", $subr_name, "header_line = $header_line");
|
|
|
|
my $header_length = length ($header_line);
|
|
$max_header_length = max ($max_header_length, $header_length);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD Should change this and not yet include html in header_lines
|
|
#------------------------------------------------------------------------------
|
|
$html_line = "<b>" . $header_line . "</b>";
|
|
|
|
push (@header_lines, $html_line);
|
|
|
|
gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length");
|
|
gp_message ("debugXL", $subr_name, "html_line = $html_line");
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# This is a line with function data.
|
|
#------------------------------------------------------------------------------
|
|
if ($scan_function_data and (not ($input_line =~ /$empty_line_regex/)))
|
|
{
|
|
@fields = split (" ", $input_line);
|
|
|
|
$no_of_fields = $#fields + 1;
|
|
$elements_in_name = $no_of_fields - $number_of_metrics - 1;
|
|
|
|
gp_message ("debugXL", $subr_name, "no_of_fields = $no_of_fields elements_in_name = $elements_in_name");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Handle this better in case a function entry has more than 2 words.
|
|
# Build the regex dynamically and use eval to capture the correct group.
|
|
# CHECK CODE IN GENERATE_CALLER_CALLEE
|
|
#------------------------------------------------------------------------------
|
|
if ($elements_in_name == 1)
|
|
{
|
|
$name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)';
|
|
}
|
|
elsif ($elements_in_name == 2)
|
|
{
|
|
$name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+((\S+)\s+(\S+))\s+(.*)';
|
|
}
|
|
else
|
|
{
|
|
gp_message ("error", $subr_name, "assertion error: $elements_in_name elements in name exceeds limit");
|
|
}
|
|
|
|
if ($input_line =~ /$name_regex/)
|
|
{
|
|
$full_hex_address = $1;
|
|
$routine = $2;
|
|
|
|
if ($elements_in_name == 1)
|
|
{
|
|
$all_metrics = $3;
|
|
}
|
|
elsif ($elements_in_name == 2)
|
|
{
|
|
$all_metrics = $5;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# In case the last metric is 0. only, we append 3 extra characters that
|
|
# represent zero. We cannot change the number to 0.000 though because that
|
|
# has a different interpretation than 0.
|
|
# In a later phase, the "ZZZ" symbol will be removed again, but for now it
|
|
# creates consistency in, for example, the length of the metrics part.
|
|
#------------------------------------------------------------------------------
|
|
if ($all_metrics =~ /$zero_dot_at_end_regex/)
|
|
{
|
|
if (defined ($1) )
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Somewhat overkill, but remove the leading "\" from the decimal separator
|
|
# in the debug print since it is used for internal purposes only.
|
|
#------------------------------------------------------------------------------
|
|
my $decimal_point = $decimal_separator;
|
|
$decimal_point =~ s/$backward_slash_regex//;
|
|
my $txt = "all_metrics = $all_metrics ended with 0";
|
|
$txt .= "$decimal_point ($decimal_separator)";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
|
|
$all_metrics .= "ZZZ";
|
|
}
|
|
}
|
|
$metrics_length = length ($all_metrics);
|
|
$max_metrics_length = max ($max_metrics_length, $metrics_length);
|
|
gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length");
|
|
|
|
if ($full_hex_address =~ /$get_hex_address_regex/)
|
|
{
|
|
$hex_address = "0x" . $2;
|
|
}
|
|
|
|
push (@address_field, $hex_address);
|
|
push (@metric_values, $all_metrics);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Record the function name "as is". Below we figure out what the final name
|
|
# should be in case there are multiple occurrences of the same name.
|
|
#
|
|
# The reason to decouple this is to avoid the code gets too complex here.
|
|
#------------------------------------------------------------------------------
|
|
push (@function_names, $routine);
|
|
}
|
|
}
|
|
} #-- End of loop over the input lines
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Store the maximum lengths for the header and metrics.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "final max_header_length = $max_header_length");
|
|
gp_message ("debugXL", $subr_name, "final max_metrics_length = $max_metrics_length");
|
|
|
|
$function_view_structure{"max header length"} = $max_header_length;
|
|
$function_view_structure{"max metrics length"} = $max_metrics_length;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Determine the final name for the functions and set up the HTML block.
|
|
#------------------------------------------------------------------------------
|
|
my @final_html_function_block = ();
|
|
my @function_index_list = ();
|
|
|
|
#------------------------------------------------------------------------------
|
|
# First, an index list is built. If we are to index the functions in order of
|
|
# appearance in the function overview from 0 to n-1, the value of the array
|
|
# for index "i" is the index into the large "function_info" structure. This
|
|
# has the final name, the html function block, etc.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
## TBD: Use get_index_function_info??!!
|
|
#------------------------------------------------------------------------------
|
|
for my $i (keys @function_names)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Get the function name and the address from the function overview. The
|
|
# address is used to differentiate in case a function has multiple occurences.
|
|
#------------------------------------------------------------------------------
|
|
my $routine = $function_names[$i];
|
|
my $current_address = $address_field[$i];
|
|
|
|
my $found_a_match = $FALSE;
|
|
my $final_function_name;
|
|
my $ref_index;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if there are duplicate entries for this function. If there are, use
|
|
# the address to find the right match in the function_info structure.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "$routine: first check for multiple occurrences");
|
|
if (exists ($g_multi_count_function{$routine}))
|
|
{
|
|
gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
|
|
for my $ref (keys @{ $g_map_function_to_index{$routine} })
|
|
{
|
|
my $ref_index = $g_map_function_to_index{$routine}[$ref];
|
|
my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
|
|
#------------------------------------------------------------------------------
|
|
# The address has the following format: 6:0x0003af50, but we only need the
|
|
# part after the colon and remove the first part.
|
|
#------------------------------------------------------------------------------
|
|
$addr_offset =~ s/$get_addr_offset_regex//;
|
|
|
|
gp_message ("debugXL", $subr_name, "$routine: ref_index = $ref_index");
|
|
gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
|
|
gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
|
|
|
|
if ($addr_offset eq $current_address)
|
|
#------------------------------------------------------------------------------
|
|
# There is a match and we can store the index.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$found_a_match = $TRUE;
|
|
push (@function_index_list, $ref_index);
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# This is the easy case. There is only one index value. We do check if the
|
|
# array element that contains it, exists. If this is not the case, something
|
|
# has gone horribly wrong earlier and we need to bail out.
|
|
#------------------------------------------------------------------------------
|
|
if (defined ($g_map_function_to_index{$routine}[0]))
|
|
{
|
|
$found_a_match = $TRUE;
|
|
$ref_index = $g_map_function_to_index{$routine}[0];
|
|
push (@function_index_list, $ref_index);
|
|
my $final_function_name = $function_info[$ref_index]{"routine"};
|
|
gp_message ("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name");
|
|
}
|
|
}
|
|
if (not $found_a_match)
|
|
#------------------------------------------------------------------------------
|
|
# This should not happen. All we can do is print an error message and stop.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my $msg = "cannot find the index for $routine: found_a_match = ";
|
|
$msg .= ($found_a_match == $TRUE) ? "TRUE" : "FALSE";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The loop over all function names has completed and @function_index_list
|
|
# contains the index values into @function_info for the functions.
|
|
#
|
|
# All we now need to do is to retrieve the correct field(s) from the array.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (keys @function_index_list)
|
|
{
|
|
my $index_for_function = $function_index_list[$i];
|
|
push (@final_html_function_block, $function_info[$index_for_function]{"html function block"});
|
|
}
|
|
for my $i (keys @final_html_function_block)
|
|
{
|
|
my $txt = "final_html_function_block[$i] = $final_html_function_block[$i]";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Since the numbers are right aligned, we know that any difference between the
|
|
# metric line length and the maximum must be caused by the first column. All
|
|
# we need to do is to prepend spaces in case of a difference.
|
|
#
|
|
# While we have the line with the metric values, we also replace ZZZ by 3
|
|
# spaces.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (keys @metric_values)
|
|
{
|
|
if (length ($metric_values[$i]) < $max_metrics_length)
|
|
{
|
|
my $pad = $max_metrics_length - length ($metric_values[$i]);
|
|
my $spaces = "";
|
|
for my $s (1 .. $pad)
|
|
{
|
|
$spaces .= " ";
|
|
}
|
|
$metric_values[$i] = $spaces . $metric_values[$i];
|
|
}
|
|
$metric_values[$i] =~ s/ZZZ/ /g;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Determine the column widths. The start and end index of the words in the
|
|
# input line are stored in elements 0 and 1 of @word_index_values.
|
|
#
|
|
# The assumption made is that the first digit of a metric value on the first
|
|
# line is left # aligned with the header text. These are the Total values
|
|
# and other than for some derived metrics, e.g. CPI, should be the largest.
|
|
#
|
|
# The positions of the start of the value is what we should then use for the
|
|
# word "(sort)" to start.
|
|
#
|
|
# For example:
|
|
#
|
|
# Excl. Excl. CPU Excl. Excl. Excl. Excl.
|
|
# Total Cycles Instructions Last-Level IPC CPI
|
|
# CPU sec. sec. Executed Cache Misses
|
|
# 174.664 179.250 175838403203 1166209617 0.428 2.339
|
|
#------------------------------------------------------------------------------
|
|
|
|
my $foundit_ref;
|
|
my $foundit;
|
|
my @index_values = ();
|
|
my $index_values_ref;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Search for "Excl." in the top row. The metric values are aligned with this
|
|
# word and we can use it to position "(sort)" in the last header line.
|
|
#
|
|
# In @index_values, we store the position(s) of "Excl." in the header line.
|
|
# If none can be found, an exception is raised because at least one should
|
|
# be there.
|
|
#
|
|
# TBD: Check if this can be done only once.
|
|
# ------------------------------------------------------------------------------
|
|
my $target_keyword = "Excl.";
|
|
|
|
($foundit_ref, $index_values_ref) = find_keyword_in_string (
|
|
\$remaining_part_header,
|
|
\$target_keyword);
|
|
|
|
$foundit = ${ $foundit_ref };
|
|
@index_values = @{ $index_values_ref };
|
|
|
|
if ($foundit)
|
|
{
|
|
for my $i (keys @index_values)
|
|
{
|
|
my $txt = "index_values[$i] = $index_values[$i]";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "keyword $target_keyword not found in $remaining_part_header";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# Compute the number of spaces we need to add between the "(sort)" strings.
|
|
#
|
|
# For example:
|
|
#
|
|
# 01234567890123456789
|
|
#
|
|
# Excl. Excl.
|
|
# (sort) (sort)
|
|
# xxxxxxxx
|
|
#
|
|
# The number of spaces required is 14 - 6 = 8.
|
|
#
|
|
# The number of spaces to be added is stored in @padding_values. These are
|
|
# the spaces to be added before the occurrence of "(sort)". This is why the
|
|
# first padding value is 0.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# TBD: This needs to be done only once.
|
|
# ------------------------------------------------------------------------------
|
|
my @padding_values = ();
|
|
my $P_previous = 0;
|
|
for my $i (keys @index_values)
|
|
{
|
|
my $L = $index_values[$i];
|
|
my $P = $L + length ("(sort)");
|
|
my $pad_spaces = $L - $P_previous;
|
|
|
|
push (@padding_values, $pad_spaces);
|
|
|
|
$P_previous = $P;
|
|
}
|
|
|
|
for my $i (keys @padding_values)
|
|
{
|
|
my $txt = "padding_values[$i] = $padding_values[$i]";
|
|
gp_message ("debugXL", $subr_name, $txt);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Build up the sort line. Mark the current metric and make sure the line is
|
|
# aligned with the header.
|
|
#------------------------------------------------------------------------------
|
|
my $sort_string = "(sort)";
|
|
my $length_sort_string = length ($sort_string);
|
|
my $sort_line = "";
|
|
my @active_metrics = split (":", $summary_metrics);
|
|
for my $i (0 .. $number_of_metrics-1)
|
|
{
|
|
my $pad = $padding_values[$i];
|
|
my $metric_value = $active_metrics[$i];
|
|
|
|
my $spaces = "";
|
|
for my $s (1 .. $pad)
|
|
{
|
|
$spaces .= " ";
|
|
}
|
|
|
|
gp_message ("debugXL", $subr_name, "i = $i metric_value = $metric_value pad = $pad");
|
|
|
|
if ($metric_value eq $exp_type)
|
|
#------------------------------------------------------------------------------
|
|
# The current metric should have a different background color.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
|
|
"." . $metric_value . ".html' style='background-color:" .
|
|
$g_html_color_scheme{"background_selected_sort"} .
|
|
"\'><b>(sort)</b></a>";
|
|
}
|
|
elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric))
|
|
#------------------------------------------------------------------------------
|
|
# Set the background color for the sort metric in the main function overview.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
|
|
"." . $metric_value . ".html' style='background-color:" .
|
|
$g_html_color_scheme{"background_selected_sort"} .
|
|
"'><b>(sort)</b></a>";
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# Do not set a specific background for all other metrics.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
|
|
"." . $metric_value . ".html'>(sort)</a>";
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Prepend the spaces to ensure correct alignment with the rest of the header.
|
|
#------------------------------------------------------------------------------
|
|
$sort_line .= $spaces . $sort_string;
|
|
}
|
|
|
|
push (@header_lines, $sort_line);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the final results for the header and metrics.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (keys @header_lines)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]");
|
|
}
|
|
for my $i (keys @metric_values)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "metric_values[$i] = $metric_values[$i]");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Construct the lines for the function overview.
|
|
#
|
|
# TBD: We could eliminate two structures here because metric_values and
|
|
# final_html_function_block are only copied and the result stored.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (keys @function_names)
|
|
{
|
|
push (@metrics_part, $metric_values[$i]);
|
|
push (@function_view_array, $final_html_function_block[$i]);
|
|
}
|
|
|
|
for my $i (0 .. $#function_view_array)
|
|
{
|
|
my $msg = "function_view_array[$i] = $function_view_array[$i]";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Element "function table" contains the array with all the function view data.
|
|
#------------------------------------------------------------------------------
|
|
$function_view_structure{"header"} = [@header_lines];
|
|
$function_view_structure{"metrics part"} = [@metrics_part];
|
|
$function_view_structure{"function table"} = [@function_view_array];
|
|
|
|
return (\%function_view_structure);
|
|
|
|
} #-- End of subroutine process_function_overview
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub process_metrics
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_string, $sort_fields_ref, $metric_description_ref, $ignored_metrics_ref) = @_;
|
|
|
|
my @sort_fields = @{ $sort_fields_ref };
|
|
my %metric_description = %{ $metric_description_ref };
|
|
my %ignored_metrics = %{ $ignored_metrics_ref };
|
|
|
|
my $outputdir = append_forward_slash ($input_string);
|
|
my $LANG = $g_locale_settings{"LANG"};
|
|
my $max_len = 0;
|
|
my $metric_comment;
|
|
|
|
my ($imetricn,$outfile);
|
|
my ($html_metrics_record,$imetric,$metric);
|
|
|
|
$html_metrics_record =
|
|
"<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" .
|
|
"<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" .
|
|
"<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n";
|
|
|
|
$outfile = $outputdir . "metrics.html";
|
|
|
|
open (METRICSOUT, ">", $outfile)
|
|
or die ("$subr_name - unable to open file $outfile for writing - '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile for writing");
|
|
|
|
for $metric (@sort_fields)
|
|
{
|
|
$max_len = max ($max_len, length ($metric));
|
|
gp_message ("debug", $subr_name, "sort_fields: metric = $metric max_len = $max_len");
|
|
}
|
|
|
|
# TBD: Check this
|
|
# for $imetric (@IMETRICS)
|
|
for $imetric (keys %ignored_metrics)
|
|
{
|
|
$max_len = max ($max_len, length ($imetric));
|
|
gp_message ("debug", $subr_name, "ignored_metrics imetric = $imetric max_len = $max_len");
|
|
}
|
|
|
|
$max_len++;
|
|
|
|
gp_message ("debug", $subr_name, "max_len = $max_len");
|
|
|
|
$html_metrics_record .= "<p style=\"font-size:14px;color:red\"> Metrics used (".($#sort_fields + 1).")\n</p><p style=\"font-size:14px\">";
|
|
for $metric (@sort_fields)
|
|
{
|
|
my $description = ${ retrieve_metric_description (\$metric, \%metric_description) };
|
|
gp_message ("debug", $subr_name, "handling metric metric = $metric->$description");
|
|
$html_metrics_record .= " $metric".(' ' x ($max_len - length ($metric)))."$description\n";
|
|
}
|
|
|
|
# $imetricn = scalar (keys %IMETRICS);
|
|
$imetricn = scalar (keys %ignored_metrics);
|
|
if ($imetricn)
|
|
{
|
|
$html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">";
|
|
# for $imetric (sort keys %IMETRICS){
|
|
for $imetric (sort keys %ignored_metrics)
|
|
{
|
|
$metric_comment = "(inclusive, exclusive, and percentages)";
|
|
$html_metrics_record .= " $imetric".(' ' x ($max_len - length ($imetric))).$metric_comment."\n";
|
|
gp_message ("debug", $subr_name, "handling metric imetric = $imetric $metric_comment");
|
|
}
|
|
}
|
|
|
|
print METRICSOUT $html_metrics_record;
|
|
print METRICSOUT $g_html_credits_line;
|
|
close (METRICSOUT);
|
|
|
|
gp_message ("debug", $subr_name, "closed metrics file $outfile");
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine process_metrics
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# TBD
|
|
#-------------------------------------------------------------------------------
|
|
sub process_metrics_data
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($outfile1, $outfile2, $ignored_metrics_ref) = @_;
|
|
|
|
my %ignored_metrics = %{ $ignored_metrics_ref };
|
|
|
|
my %metric_value = ();
|
|
my %metric_description = ();
|
|
my %metric_found = ();
|
|
|
|
my $user_metrics;
|
|
my $system_metrics;
|
|
my $wall_metrics;
|
|
my $metric_spec;
|
|
my $metric_flavor;
|
|
my $metric_visibility;
|
|
my $metric_name;
|
|
my $metric_text;
|
|
my $metricdata;
|
|
my $metric_line;
|
|
|
|
my $summary_metrics;
|
|
my $detail_metrics;
|
|
my $detail_metrics_system;
|
|
my $call_metrics;
|
|
|
|
if ($g_user_settings{"default_metrics"}{"current_value"} eq "off")
|
|
{
|
|
gp_message ("debug", $subr_name, "g_user_settings{default_metrics}{current_value} = " . $g_user_settings{"default_metrics"}{"current_value"});
|
|
# get metrics
|
|
|
|
$summary_metrics='';
|
|
$detail_metrics='';
|
|
$detail_metrics_system='';
|
|
$call_metrics = '';
|
|
$user_metrics=0;
|
|
$system_metrics=0;
|
|
$wall_metrics=0;
|
|
|
|
my ($last_metric,$metric,$value,$i,$r);
|
|
|
|
open (METRICTOTALS, "<", $outfile2)
|
|
or die ("Unable to open metric value data file $outfile2 for reading - '$!'");
|
|
gp_message ("debug", $subr_name, "opened $outfile2 to parse metric value data");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Below an example of the file that has just been opened. The lines I marked
|
|
# with a * has been wrapped by my for readability. This is not the case in the
|
|
# file, but makes for a really long line.
|
|
#
|
|
# Also, the data comes from one PC experiment and two HWC experiments.
|
|
#------------------------------------------------------------------------------
|
|
# <Total>
|
|
# Exclusive Total CPU Time: 32.473 (100.0%)
|
|
# Inclusive Total CPU Time: 32.473 (100.0%)
|
|
# Exclusive CPU Cycles: 23.586 (100.0%)
|
|
# " count: 47054706905
|
|
# Inclusive CPU Cycles: 23.586 (100.0%)
|
|
# " count: 47054706905
|
|
# Exclusive Instructions Executed: 54417033412 (100.0%)
|
|
# Inclusive Instructions Executed: 54417033412 (100.0%)
|
|
# Exclusive Last-Level Cache Misses: 252730685 (100.0%)
|
|
# Inclusive Last-Level Cache Misses: 252730685 (100.0%)
|
|
# * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle:
|
|
# * Exclusive Cycles Per Instruction:
|
|
# * Inclusive Cycles Per Instruction:
|
|
# * Size: 0
|
|
# PC Address: 1:0x00000000
|
|
# Source File: (unknown)
|
|
# Object File: (unknown)
|
|
# Load Object: <Total>
|
|
# Mangled Name:
|
|
# Aliases:
|
|
#------------------------------------------------------------------------------
|
|
|
|
while (<METRICTOTALS>)
|
|
{
|
|
$metricdata = $_; chomp ($metricdata);
|
|
gp_message ("debug", $subr_name, "file metrictotals: $metricdata");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Ignoring whitespace, search for any line with a ":" in it, followed by
|
|
# a number with or without a dot. So, an integer or floating-point number.
|
|
#------------------------------------------------------------------------------
|
|
if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/)
|
|
{
|
|
gp_message ("debug", $subr_name, " candidate => $metricdata");
|
|
$metric = $1;
|
|
$value = $2;
|
|
if ( ($metric eq "PC Address") or ($metric eq "Size"))
|
|
{
|
|
gp_message ("debug", $subr_name, " skipped => $metric $value");
|
|
next;
|
|
}
|
|
gp_message ("debug", $subr_name, " proceed => $metric $value");
|
|
if ($metric eq '" count')
|
|
#------------------------------------------------------------------------------
|
|
# Hardware counter experiments have this info. Note that this line is not the
|
|
# first one to be encountered, so $last_metric has been defined already.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$metric = $last_metric." Count"; # we presume .......
|
|
gp_message ("debug", $subr_name, "last_metric = $last_metric metric = $metric");
|
|
}
|
|
$i=index ($metricdata,":");
|
|
$r=rindex ($metricdata,":");
|
|
gp_message ("debug", $subr_name, "metricdata = $metricdata => i = $i r = $r");
|
|
if ($i == $r)
|
|
{
|
|
if ($value > 0) # Not interested in metrics contributing zero
|
|
{
|
|
$metric_value{$metric} = $value;
|
|
gp_message ("debug", $subr_name, "archived metric_value{$metric} = $metric_value{$metric}");
|
|
# e.g. $metric_value{Exclusive Total Thread Time} = 302.562
|
|
# e.g. $metric_value{Exclusive Instructions Executed} = 2415126222484
|
|
}
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# TBD This code deals with an old bug and may be removed.
|
|
#------------------------------------------------------------------------------
|
|
{ # er_print bug - e.g.
|
|
# Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: Exclusive Cycles Per Instruction: Inclusive Cycles Per Instruction: Exclusive OpenMP Work Time: 162.284 (100.0%)
|
|
gp_message ("debug", $subr_name, "metrictotals odd line:->$metricdata<-");
|
|
$r=rindex ($metricdata,":",$r-1);
|
|
if ($r == -1)
|
|
{ # ignore
|
|
gp_message ("debug", $subr_name, "metrictotals odd line ignored<-");
|
|
$last_metric = "foo";
|
|
next;
|
|
}
|
|
my ($good_part)=substr ($metricdata,$r+1);
|
|
if ($good_part =~ /\s*(.*):\s+(\d+\.*\d*)/)
|
|
{
|
|
$metric = $1;
|
|
$value = $2;
|
|
if ($value>0) # Not interested in metrics contributing zero
|
|
{
|
|
$metric_value{$metric} = $value;
|
|
my $msg = "metrictotals odd line rescued '$metric'=$value";
|
|
gp_message ("debug", $subr_name, $msg);
|
|
}
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Preserve the current metric.
|
|
#------------------------------------------------------------------------------
|
|
$last_metric = $metric;
|
|
}
|
|
}
|
|
close (METRICTOTALS);
|
|
}
|
|
|
|
if (scalar (keys %metric_value) == 0)
|
|
#------------------------------------------------------------------------------
|
|
# If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we
|
|
# blow up later.
|
|
#
|
|
# TBD: See if this can be handled differently.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$metric_value{"Exclusive Total CPU Time"} = 0;
|
|
gp_message ("debug", $subr_name, "no metrics found and a stub was added");
|
|
}
|
|
|
|
for my $metric (sort keys %metric_value)
|
|
{
|
|
gp_message ("debug", $subr_name, "Stored metric_value{$metric} = $metric_value{$metric}");
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "proceed to process file $outfile1");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Open and process the metrics file.
|
|
#------------------------------------------------------------------------------
|
|
open (METRICS, "<", $outfile1)
|
|
or die ("Unable to open metrics file $outfile1: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $outfile1 for reading");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Parse the file. This is a typical example:
|
|
#
|
|
# Exp Sel Total
|
|
# === === =====
|
|
# 1 all 2
|
|
# 2 all 1
|
|
# 3 all 2
|
|
# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name
|
|
# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
|
|
# Available metrics:
|
|
# Exclusive Total CPU Time: e.%totalcpu
|
|
# Inclusive Total CPU Time: i.%totalcpu
|
|
# Exclusive CPU Cycles: e.+%cycles
|
|
# Inclusive CPU Cycles: i.+%cycles
|
|
# Exclusive Instructions Executed: e+%insts
|
|
# Inclusive Instructions Executed: i+%insts
|
|
# Exclusive Last-Level Cache Misses: e+%llm
|
|
# Inclusive Last-Level Cache Misses: i+%llm
|
|
# Exclusive Instructions Per Cycle: e+IPC
|
|
# Inclusive Instructions Per Cycle: i+IPC
|
|
# Exclusive Cycles Per Instruction: e+CPI
|
|
# Inclusive Cycles Per Instruction: i+CPI
|
|
# Size: size
|
|
# PC Address: address
|
|
# Name: name
|
|
#------------------------------------------------------------------------------
|
|
while (<METRICS>)
|
|
{
|
|
$metric_line = $_;
|
|
chomp ($metric_line);
|
|
|
|
gp_message ("debug", $subr_name, "processing line $metric_line");
|
|
#------------------------------------------------------------------------------
|
|
# The original regex has bugs because the line should not be allowed to start
|
|
# with a ":". So this is wrong:
|
|
# if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/))
|
|
#
|
|
# This is better:
|
|
# if (($metric =~ /\s*(.+):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/))
|
|
#
|
|
# In general, this regex has some potential issues and has been replaced by
|
|
# the one shown below.
|
|
#
|
|
# We select a line that does not start with "Current" and aside from whitespace
|
|
# starts with anything (although it should be a string with words only),
|
|
# followed by whitespace and either an "e" or "i". This is called the "flavor"
|
|
# and is followed by a visibility marker (.,+,%, or !) and a metric name.
|
|
#------------------------------------------------------------------------------
|
|
# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){
|
|
|
|
($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) =
|
|
extract_metric_specifics ($metric_line);
|
|
|
|
# if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/))
|
|
if ($metric_spec eq "skipped")
|
|
{
|
|
gp_message ("debug", $subr_name, "skipped line: $metric_line");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "line of interest: $metric_line");
|
|
|
|
$metric_found{$metric_spec} = 1;
|
|
|
|
if ($g_user_settings{"ignore_metrics"}{"defined"})
|
|
{
|
|
gp_message ("debug", $subr_name, "check for $metric_spec");
|
|
if (exists ($ignored_metrics{$metric_name}))
|
|
{
|
|
gp_message ("debug", $subr_name, "user asked to ignore metric $metric_name");
|
|
next;
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This metric is not on the ignored list and qualifies, so store it.
|
|
#------------------------------------------------------------------------------
|
|
$metric_description{$metric_spec} = $metric_text;
|
|
|
|
# TBD: add for other visibilities too, like +
|
|
gp_message ("debug", $subr_name, "stored $metric_description{$metric_spec} = $metric_description{$metric_spec}");
|
|
|
|
if ($metric_flavor ne "e")
|
|
{
|
|
gp_message ("debug", $subr_name, "metric $metric_spec is ignored");
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# Only the exclusive metrics are shown.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("debug", $subr_name, "metric $metric_spec ($metric_text) is considered");
|
|
|
|
if ($metric_spec =~ /user/)
|
|
{
|
|
$user_metrics = $TRUE;
|
|
gp_message ("debug", $subr_name, "m: user_metrics set to TRUE");
|
|
}
|
|
elsif ($metric_spec =~ /system/)
|
|
{
|
|
$system_metrics = $TRUE;
|
|
gp_message ("debug", $subr_name, "m: system_metrics set to TRUE");
|
|
}
|
|
elsif ($metric_spec =~ /wall/)
|
|
{
|
|
$wall_metrics = $TRUE;
|
|
gp_message ("debug", $subr_name, "m: wall_metrics set to TRUE");
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# TBD I don't see why these need to be skipped. Also, should be totalcpu.
|
|
#------------------------------------------------------------------------------
|
|
elsif (($metric_spec =~ /^e\.total$/) or ($metric_spec =~/^e\.total_cpu$/))
|
|
{
|
|
# skip total thread time and total CPU time
|
|
gp_message ("debug", $subr_name, "m: skip above");
|
|
}
|
|
elsif (defined ($metric_value{$metric_text}))
|
|
{
|
|
gp_message ("debug", $subr_name, "Total attributed to this metric metric_value{$metric_text} = $metric_value{$metric_text}");
|
|
if ($summary_metrics ne '')
|
|
{
|
|
$summary_metrics = $summary_metrics.':'.$metric_spec;
|
|
gp_message ("debug", $subr_name, "updated summary_metrics = $summary_metrics - 1");
|
|
if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/)
|
|
{
|
|
$detail_metrics = $detail_metrics.':'.$metric_spec;
|
|
gp_message ("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1");
|
|
$detail_metrics_system = $detail_metrics_system.':'.$metric_spec;
|
|
gp_message ("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
$summary_metrics = $metric_spec;
|
|
gp_message ("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2");
|
|
if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/)
|
|
{
|
|
$detail_metrics = $metric_spec;
|
|
gp_message ("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2");
|
|
$detail_metrics_system = $metric_spec;
|
|
gp_message ("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system");
|
|
}
|
|
}
|
|
gp_message ("debug", $subr_name, " metric $metric_spec added");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "m: no want above metric was a 0 total");
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
close METRICS;
|
|
|
|
if ($wall_metrics > 0)
|
|
{
|
|
gp_message ("debug", $subr_name,"m:wall_metrics set adding to summary_metrics");
|
|
$summary_metrics = "e.wall:".$summary_metrics;
|
|
gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 3");
|
|
}
|
|
|
|
if ($system_metrics > 0)
|
|
{
|
|
gp_message ("debug", $subr_name,"m:system_metrics set adding to summary_metrics,call_metrics and detail_metrics_system");
|
|
$summary_metrics = "e.system:".$summary_metrics;
|
|
$call_metrics = "i.system:".$call_metrics;
|
|
$detail_metrics_system ='e.system:'.$detail_metrics_system;
|
|
|
|
gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 4");
|
|
gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics");
|
|
gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 3");
|
|
}
|
|
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: e.user and i.user do not always exist!!
|
|
#------------------------------------------------------------------------------
|
|
|
|
if ($user_metrics > 0)
|
|
{
|
|
gp_message ("debug", $subr_name,"m:user_metrics set adding to summary_metrics,detail_metrics,detail_metrics_system and call_metrics");
|
|
# Ruud if (!exists ($IMETRICS{"i.user"})){
|
|
if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"}))
|
|
{
|
|
$summary_metrics = "e.user:".$summary_metrics;
|
|
}
|
|
else
|
|
{
|
|
$summary_metrics = "e.user:i.user:".$summary_metrics;
|
|
}
|
|
$detail_metrics = "e.user:".$detail_metrics;
|
|
$detail_metrics_system = "e.user:".$detail_metrics_system;
|
|
|
|
gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 5");
|
|
gp_message ("debug", $subr_name,"m:detail_metrics=$detail_metrics - 3");
|
|
gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 4");
|
|
|
|
if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"}))
|
|
{
|
|
$call_metrics = "a.user:".$call_metrics;
|
|
}
|
|
else
|
|
{
|
|
$call_metrics = "a.user:i.user:".$call_metrics;
|
|
}
|
|
gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 2");
|
|
}
|
|
|
|
if ($call_metrics eq "")
|
|
{
|
|
$call_metrics = $detail_metrics;
|
|
|
|
gp_message ("debug", $subr_name,"m:call_metrics is not set, setting it to detail_metrics ");
|
|
gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 3");
|
|
}
|
|
|
|
for my $metric (sort keys %ignored_metrics)
|
|
{
|
|
if ($ignored_metrics{$metric})
|
|
{
|
|
gp_message ("debug", $subr_name, "active metric, but ignored: $metric");
|
|
}
|
|
|
|
}
|
|
|
|
return (\%metric_value, \%metric_description, \%metric_found, $user_metrics, $system_metrics, $wall_metrics,
|
|
$summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics);
|
|
|
|
} #-- End of subroutine process_metrics_data
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process source lines that are not part of the target function.
|
|
#
|
|
# Generate straightforward HTML, but define an anchor based on the source line
|
|
# number in the list.
|
|
#------------------------------------------------------------------------------
|
|
sub process_non_target_source
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($start_scan, $end_scan,
|
|
$src_times_regex, $function_regex, $number_of_metrics,
|
|
$file_contents_ref, $modified_html_ref) = @_;
|
|
|
|
my @file_contents = @{ $file_contents_ref };
|
|
my @modified_html = @{ $modified_html_ref };
|
|
my $colour_code_line = $FALSE;
|
|
my $input_line;
|
|
my $line_id;
|
|
my $modified_line;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Main loop to parse all of the source code and take action as needed.
|
|
#------------------------------------------------------------------------------
|
|
for (my $line_no=$start_scan; $line_no <= $end_scan; $line_no++)
|
|
{
|
|
$input_line = $file_contents[$line_no];
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate straightforward HTML, but define an anchor based on the source line
|
|
# number in the list.
|
|
#------------------------------------------------------------------------------
|
|
$line_id = extract_source_line_number ($src_times_regex,
|
|
$function_regex,
|
|
$number_of_metrics,
|
|
$input_line);
|
|
|
|
if ($input_line =~ /$function_regex/)
|
|
{
|
|
$colour_code_line = $TRUE;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We need to replace the "<" symbol in the code by "<".
|
|
#------------------------------------------------------------------------------
|
|
$input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add an id.
|
|
#------------------------------------------------------------------------------
|
|
$modified_line = "<a id=\"line_" . $line_id . "\"></a>";
|
|
|
|
my $coloured_line;
|
|
if ($colour_code_line)
|
|
{
|
|
my $boldface = $TRUE;
|
|
$coloured_line = color_string (
|
|
$input_line,
|
|
$boldface,
|
|
$g_html_color_scheme{"non_target_function_name"});
|
|
$colour_code_line = $FALSE;
|
|
$modified_line .= "$coloured_line";
|
|
}
|
|
else
|
|
{
|
|
$modified_line .= "$input_line";
|
|
}
|
|
gp_message ("debugXL", $subr_name, " $line_no : modified_line = $modified_line");
|
|
push (@modified_html, $modified_line);
|
|
}
|
|
|
|
return (\@modified_html);
|
|
|
|
} #-- End of subroutine process_non_target_source
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This function scans the configuration file and adapts the internal settings
|
|
# accordingly.
|
|
#
|
|
# Errors are stored during the parsing and processing phase. They are printed
|
|
# at the end and sorted by line number.
|
|
#------------------------------------------------------------------------------
|
|
sub process_rc_file
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($rc_file_name, $rc_file_paths_ref) = @_;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Local structures.
|
|
#------------------------------------------------------------------------------
|
|
my %rc_settings_user = (); #-- Store the values extracted from the config file
|
|
my %error_and_warning_msgs = ();
|
|
my @rc_file_paths = ();
|
|
|
|
my @split_line;
|
|
my @my_fields;
|
|
|
|
my $message;
|
|
my $first_part;
|
|
my $line;
|
|
my $line_number;
|
|
my $number_of_fields;
|
|
my $number_of_paths;
|
|
my $parse_errors; #-- Count the number of errors
|
|
my $parse_warnings; #-- Count the number of errors
|
|
|
|
my $rc_config_file;
|
|
my $rc_file_found;
|
|
my $rc_keyword;
|
|
my $rc_value;
|
|
|
|
@rc_file_paths = @{$rc_file_paths_ref};
|
|
$number_of_paths = scalar (@rc_file_paths);
|
|
|
|
if ($number_of_paths == 0)
|
|
#------------------------------------------------------------------------------
|
|
# This should not happen, but is a good safety net to add.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my $msg = "search path list is empty";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check for the presence of a configuration file.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths");
|
|
|
|
$rc_file_found = $FALSE;
|
|
for my $path_name (@rc_file_paths)
|
|
{
|
|
$rc_config_file = $path_name . "/" . $rc_file_name;
|
|
gp_message ("debug", $subr_name, "looking for configuration file $rc_config_file");
|
|
if (-f $rc_config_file)
|
|
{
|
|
gp_message ("debug", $subr_name, "found configuration file $rc_config_file");
|
|
$rc_file_found = $TRUE;
|
|
last;
|
|
}
|
|
}
|
|
|
|
if (not $rc_file_found)
|
|
#------------------------------------------------------------------------------
|
|
# There is no configuration file and we can skip this subroutine.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("verbose", $subr_name, "Configuration file $rc_file_name not found");
|
|
return (0);
|
|
}
|
|
else
|
|
{
|
|
open (GP_DISPLAY_HTML_RC, "<", "$rc_config_file")
|
|
or die ("$subr_name - unable to open file $rc_config_file for reading: $!");
|
|
#------------------------------------------------------------------------------
|
|
# The configuration file has been opened for reading.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "file $rc_config_file has been opened for reading");
|
|
}
|
|
|
|
gp_message ("verbose", $subr_name, "Found configuration file $rc_config_file");
|
|
gp_message ("debug", $subr_name, "processing configuration file $rc_config_file");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Here we scan the configuration file for the settings.
|
|
#
|
|
# A setting consists of a keyword, optionally followed by a value. It is
|
|
# optional because not all keywords may require a value.
|
|
#
|
|
# At the end of this block, all keyword/value pairs are stored in a hash.
|
|
#
|
|
# We do not yet check for the validity of these pairs. This is done next.
|
|
#
|
|
# The original code had this all integrated, but it made the code very
|
|
# complex with deeply nested if-statements. The flow was also hard to follow.
|
|
#------------------------------------------------------------------------------
|
|
$parse_errors = 0;
|
|
$parse_warnings = 0;
|
|
$line_number = 0;
|
|
while (my $line = <GP_DISPLAY_HTML_RC>)
|
|
{
|
|
chomp ($line);
|
|
$line_number++;
|
|
|
|
gp_message ("debug", $subr_name, "read input line = $line");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Ignore a line with whitespace only
|
|
#------------------------------------------------------------------------------
|
|
if ($line =~ /^\s*$/)
|
|
{
|
|
gp_message ("debug", $subr_name, "ignored a line with whitespace");
|
|
next;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Ignore a comment line, defined by starting with a "#", possibly prepended by
|
|
# whitespace.
|
|
#------------------------------------------------------------------------------
|
|
if ($line =~ /^\s*\#/)
|
|
{
|
|
gp_message ("debug", $subr_name, "ignored a full comment line");
|
|
next;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Split the input line using the "#" symbol as a separator. We have already
|
|
# handled the case of an isolated comment line, so there may only be an
|
|
# embedded comment.
|
|
#
|
|
# Regardless of this, we are only interested in the first part.
|
|
#------------------------------------------------------------------------------
|
|
@split_line = split ("#", $line);
|
|
|
|
for my $i (@split_line)
|
|
{
|
|
gp_message ("debug", $subr_name, "elements after split of line: $i");
|
|
}
|
|
|
|
$first_part = $split_line[0];
|
|
gp_message ("debug", $subr_name, "relevant part = $first_part");
|
|
|
|
if ($first_part =~ /[&\^\*\@\$]+/)
|
|
#------------------------------------------------------------------------------
|
|
# The &, ^, *, @ and $ symbols should not occur. If they do, we flag an error
|
|
# an fetch the next line.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$parse_errors++;
|
|
$message = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line";
|
|
$error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
|
|
next;
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# Split the first part on whitespace and verify the number of fields to be
|
|
# valid. Although we currently only have keywords with a value, a keyword
|
|
# without value is supported to.
|
|
#
|
|
# If the number of fields is valid, the keyword and value are stored. In case
|
|
# of a single field, the value is assigned a special string.
|
|
#
|
|
# Although this situation should not occur, we do abort if something unexpected
|
|
# is encountered here.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
@my_fields = split (/\s/, $split_line[0]);
|
|
|
|
$number_of_fields = scalar (@my_fields);
|
|
gp_message ("debug", $subr_name, "number of fields = $number_of_fields");
|
|
}
|
|
|
|
if ($number_of_fields ge 3)
|
|
#------------------------------------------------------------------------------
|
|
# This is not supported.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$parse_errors++;
|
|
$message = "more than 2 fields found: $first_part";
|
|
$error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
|
|
next;
|
|
}
|
|
elsif ($number_of_fields eq 2)
|
|
{
|
|
$rc_keyword = $my_fields[0];
|
|
$rc_value = $my_fields[1];
|
|
}
|
|
elsif ($number_of_fields eq 1)
|
|
{
|
|
$rc_keyword = $my_fields[0];
|
|
$rc_value = "the_field_is_empty";
|
|
}
|
|
else
|
|
{
|
|
my $msg = "[line $line_number] $rc_config_file - number of fields = $number_of_fields";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Store the keyword, value and line number.
|
|
#------------------------------------------------------------------------------
|
|
if (exists ($rc_settings_user{$rc_keyword}))
|
|
{
|
|
$parse_warnings++;
|
|
my $prev_value = $rc_settings_user{$rc_keyword}{"value"};
|
|
my $prev_line_number = $rc_settings_user{$rc_keyword}{"line_no"};
|
|
if ($rc_value ne $prev_value)
|
|
{
|
|
$message = "option $rc_keyword previously set at line $prev_line_number: new value '$rc_value' overrides '$prev_value'";
|
|
}
|
|
else
|
|
{
|
|
$message = "option $rc_keyword previously set to the same value at line $prev_line_number";
|
|
}
|
|
$error_and_warning_msgs{"warning"}{$line_number}{"message"} = $message;
|
|
}
|
|
$rc_settings_user{$rc_keyword}{"value"} = $rc_value;
|
|
$rc_settings_user{$rc_keyword}{"line_no"} = $line_number;
|
|
|
|
gp_message ("debug", $subr_name, "stored keyword = $rc_keyword");
|
|
gp_message ("debug", $subr_name, "stored value = $rc_value");
|
|
gp_message ("debug", $subr_name, "stored line number = $line_number");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Completed the parsing of the configuration file. It can be closed.
|
|
#------------------------------------------------------------------------------
|
|
close (GP_DISPLAY_HTML_RC);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the raw input as just collected from the configuration file.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "contents of %rc_settings_user:");
|
|
for my $keyword (keys %rc_settings_user)
|
|
{
|
|
my $key_value = $rc_settings_user{$keyword}{"value"};
|
|
gp_message ("debug", $subr_name, "keyword = $keyword value = $key_value");
|
|
}
|
|
|
|
for my $rc_keyword (keys %g_user_settings)
|
|
{
|
|
for my $fields (keys %{ $g_user_settings{$rc_keyword} })
|
|
{
|
|
gp_message ("debug", $subr_name, "before config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}");
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We are almost done. Check for all keywords found whether they are valid.
|
|
# Also verify that the corresponding value is valid.
|
|
#
|
|
# Update the g_user_settings table if everything is okay.
|
|
#------------------------------------------------------------------------------
|
|
|
|
for my $rc_keyword (keys %rc_settings_user)
|
|
{
|
|
my $rc_value = $rc_settings_user{$rc_keyword}{"value"};
|
|
|
|
if (exists ( $g_user_settings{$rc_keyword}))
|
|
{
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is a supported keyword. There are two more things left to do:
|
|
# - Check how many values it requires (currently exactly one is supported)
|
|
# - Is the value a valid number or string?
|
|
#------------------------------------------------------------------------------
|
|
my $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"};
|
|
|
|
if ($no_of_arguments eq 1)
|
|
{
|
|
my $input_value = $rc_value;
|
|
if ($input_value ne "the_field_is_empty")
|
|
#
|
|
#------------------------------------------------------------------------------
|
|
# So far, so good. We only need to check if the value is valid for the keyword.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my $data_type = $g_user_settings{$rc_keyword}{"data_type"};
|
|
my $valid_input = verify_if_input_is_valid ($input_value, $data_type);
|
|
#------------------------------------------------------------------------------
|
|
# Check if the value is valid.
|
|
#------------------------------------------------------------------------------
|
|
if ($valid_input)
|
|
{
|
|
$g_user_settings{$rc_keyword}{"current_value"} = $rc_value;
|
|
$g_user_settings{$rc_keyword}{"defined"} = $TRUE;
|
|
}
|
|
else
|
|
{
|
|
$parse_errors++;
|
|
$line_number = $rc_settings_user{$rc_keyword}{"line_no"};
|
|
$message = "input value '$input_value' for keyword $rc_keyword is not valid";
|
|
$error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
|
|
next;
|
|
}
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# This keyword requires a value, but none has been found.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$parse_errors++;
|
|
$line_number = $rc_settings_user{$rc_keyword}{"line_no"};
|
|
$message = "missing value for keyword '$rc_keyword'";
|
|
$error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
|
|
next;
|
|
}
|
|
}
|
|
elsif ($no_of_arguments eq 0)
|
|
#------------------------------------------------------------------------------
|
|
# Currently a theoretical scenario since all commands require a value, but in
|
|
# case this is no longer true, we need to at least flag the fact the user set
|
|
# this command.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$g_user_settings{$rc_keyword}{"defined"} = $TRUE;
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# The code is not prepared for the situation one command has multiple values,
|
|
# but this situation should never occur. Still it won't hurt to add a check.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my $msg = "cannot handle $no_of_arguments in the input";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# A non-valid keyword is found. This is flagged as an error.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$parse_errors++;
|
|
$line_number = $rc_settings_user{$rc_keyword}{"line_no"};
|
|
$message = "keyword $rc_keyword is not supported";
|
|
$error_and_warning_msgs{"error"}{$line_number}{"message"} = $message;
|
|
}
|
|
}
|
|
for my $rc_keyword (keys %g_user_settings)
|
|
{
|
|
for my $fields (keys %{ $g_user_settings{$rc_keyword} })
|
|
{
|
|
gp_message ("debug", $subr_name, "after config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}");
|
|
}
|
|
}
|
|
print_table_user_settings ("debug", "upon the return from $subr_name");
|
|
|
|
if ( ($parse_errors == 0) and ($parse_warnings == 0) )
|
|
{
|
|
gp_message ("verbose", $subr_name, "Successfully parsed and processed the configuration file");
|
|
}
|
|
else
|
|
{
|
|
if ($parse_errors > 0)
|
|
{
|
|
my $plural_or_single = ($parse_errors > 1) ? "errors" : "error";
|
|
$message = $g_error_keyword . "found $parse_errors fatal $plural_or_single in the configuration file:";
|
|
gp_message ("debug", $subr_name, $message);
|
|
#------------------------------------------------------------------------------
|
|
# Sort the hash keys, the line numbers, alphabetically and print the
|
|
# corresponding error messages.
|
|
#------------------------------------------------------------------------------
|
|
for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"error"} }))
|
|
{
|
|
$message = $g_error_keyword. "[line $line_no] in file $rc_config_file - ";
|
|
$message .= $error_and_warning_msgs{"error"}{$line_no}{"message"};
|
|
gp_message ("debug", $subr_name, $message);
|
|
}
|
|
}
|
|
|
|
if (not $g_quiet)
|
|
{
|
|
if ($parse_warnings > 0)
|
|
{
|
|
$message = $g_warn_keyword . "found $parse_warnings warnings in the configuration file:";
|
|
gp_message ("debug", $subr_name, $message);
|
|
for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"warning"} }))
|
|
{
|
|
$message = $g_warn_keyword . "[line $line_no] in file $rc_config_file - ";
|
|
$message .= $error_and_warning_msgs{"warning"}{$line_no}{"message"};
|
|
gp_message ("debug", $subr_name, $message);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return ($parse_errors);
|
|
|
|
} #-- End of subroutine process_rc_file
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the annotated html file for the source listing.
|
|
#------------------------------------------------------------------------------
|
|
sub process_source
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($number_of_metrics, $function_info_ref,
|
|
$outputdir, $input_filename) = @_;
|
|
|
|
my @function_info = @{ $function_info_ref };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The regex section
|
|
#------------------------------------------------------------------------------
|
|
my $end_src1_header_regex = '(^\s+)(\d+)\.\s+(.*)';
|
|
my $end_src2_header_regex = '(^\s+)(<Function: )(.*)>';
|
|
my $function_regex = '^(\s*)<Function:\s(.*)>';
|
|
my $function2_regex = '^(\s*)<Function:\s(.*)>';
|
|
my $src_regex = '(\s*)(\d+)\.(.*)';
|
|
my $txt_ext_regex = '\.txt$';
|
|
my $src_filename_id_regex = '^file\.(\d+)\.src\.txt$';
|
|
my $integer_only_regex = '\d+';
|
|
#------------------------------------------------------------------------------
|
|
# Computed dynamically below.
|
|
# TBD: Try to move this up.
|
|
#------------------------------------------------------------------------------
|
|
my $src_times_regex;
|
|
my $hot_lines_regex;
|
|
my $metric_regex;
|
|
my $metric_extra_regex;
|
|
|
|
my @components = ();
|
|
my @fields_in_line = ();
|
|
my @file_contents = ();
|
|
my @hot_source_lines = ();
|
|
my @max_metric_values = ();
|
|
my @modified_html = ();
|
|
my @transposed_hot_lines = ();
|
|
|
|
my $colour_coded_line;
|
|
my $colour_coded_line_ref;
|
|
my $line_id;
|
|
my $ignore_value;
|
|
my $func_name_in_src_file;
|
|
my $html_new_line = "<br>";
|
|
my $input_line;
|
|
my $metric_values;
|
|
my $modified_html_ref;
|
|
my $modified_line;
|
|
my $is_empty;
|
|
my $start_all_source;
|
|
my $start_target_source;
|
|
my $end_target_source;
|
|
my $output_line;
|
|
my $hot_line;
|
|
my $src_line_no;
|
|
my $src_code_line;
|
|
|
|
my $decimal_separator = $g_locale_settings{"decimal_separator"};
|
|
my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
|
|
|
|
my $file_title;
|
|
my $found_target;
|
|
my $html_dis_record;
|
|
my $html_end;
|
|
my $html_header;
|
|
my $html_home;
|
|
my $rounded_percentage;
|
|
my $start_tracking;
|
|
my $threshold_line;
|
|
|
|
my $base;
|
|
my $boldface;
|
|
my $msg;
|
|
my $routine;
|
|
|
|
my $LANG = $g_locale_settings{"LANG"};
|
|
my $the_title = set_title ($function_info_ref, $input_filename,
|
|
"process source");
|
|
my $outfile = $input_filename . ".html";
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Remove the .txt from file.<n>.src.txt
|
|
#------------------------------------------------------------------------------
|
|
my $html_output_file = $input_filename;
|
|
$html_output_file =~ s/$txt_ext_regex/.html/;
|
|
|
|
gp_message ("debug", $subr_name, "input_filename = $input_filename");
|
|
gp_message ("debug", $subr_name, "the_title = $the_title");
|
|
|
|
$file_title = $the_title;
|
|
$html_header = ${ create_html_header (\$file_title) };
|
|
$html_home = ${ generate_home_link ("right") };
|
|
|
|
push (@modified_html, $html_header);
|
|
push (@modified_html, $html_home);
|
|
push (@modified_html, "<pre>");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Open the html file used for the output.
|
|
#------------------------------------------------------------------------------
|
|
open (NEW_HTML, ">", $html_output_file)
|
|
or die ("$subr_name - unable to open file $html_output_file for writing: '$!'");
|
|
gp_message ("debug", $subr_name , "opened file $html_output_file for writing");
|
|
|
|
$base = get_basename ($input_filename);
|
|
|
|
gp_message ("debug", $subr_name, "base = $base");
|
|
|
|
if ($base =~ /$src_filename_id_regex/)
|
|
{
|
|
my $file_id = $1;
|
|
if (defined ($function_info[$file_id]{"routine"}))
|
|
{
|
|
$routine = $function_info[$file_id]{"routine"};
|
|
|
|
gp_message ("debugXL", $subr_name, "target routine = $routine");
|
|
}
|
|
else
|
|
{
|
|
my $msg = "cannot retrieve routine name for file_id = $file_id";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the input file is empty. If so, generate a short text in the html
|
|
# file and return. Otherwise open the file and read the contents.
|
|
#------------------------------------------------------------------------------
|
|
$is_empty = is_file_empty ($input_filename);
|
|
|
|
if ($is_empty)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The input file is empty. Write a diagnostic message in the html file and exit.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name ,"file $input_filename is empty");
|
|
|
|
my $comment = "No source listing generated by $tool_name - " .
|
|
"file $input_filename is empty";
|
|
my $error_file = $outputdir . "gp-listings.err";
|
|
|
|
my $html_empty_file_ref = html_text_empty_file (\$comment, \$error_file);
|
|
my @html_empty_file = @{ $html_empty_file_ref };
|
|
|
|
print NEW_HTML "$_\n" for @html_empty_file;
|
|
|
|
close NEW_HTML;
|
|
|
|
return (0);
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# Open the input file with the source code
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
open (SRC_LISTING, "<", $input_filename)
|
|
or die ("$subr_name - unable to open file $input_filename for reading: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $input_filename for reading");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate the regex for the metrics. This depends on the number of metrics.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator<--");
|
|
|
|
$metric_regex = '';
|
|
$metric_extra_regex = '';
|
|
for my $metric_used (1 .. $number_of_metrics)
|
|
{
|
|
$metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+';
|
|
}
|
|
$metric_extra_regex = $metric_regex . '(\d+' . $decimal_separator . ')';
|
|
|
|
$hot_lines_regex = '^(#{2})\s+';
|
|
$hot_lines_regex .= '('.$metric_regex.')';
|
|
$hot_lines_regex .= '([0-9?]+)\.\s+(.*)';
|
|
|
|
$src_times_regex = '^(#{2}|\s{2})\s+';
|
|
$src_times_regex .= '('.$metric_extra_regex.')';
|
|
$src_times_regex .= '(.*)';
|
|
|
|
gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex");
|
|
gp_message ("debugXL", $subr_name, "hot_lines_regex = $hot_lines_regex");
|
|
gp_message ("debugXL", $subr_name, "src_times_regex = $src_times_regex");
|
|
gp_message ("debugXL", $subr_name, "src_regex = $src_regex");
|
|
|
|
gp_message ("debugXL", $subr_name, "end_src1_header_regex = $end_src1_header_regex");
|
|
gp_message ("debugXL", $subr_name, "end_src2_header_regex = $end_src2_header_regex");
|
|
gp_message ("debugXL", $subr_name, "function_regex = $function_regex");
|
|
gp_message ("debugXL", $subr_name, "function2_regex = $function2_regex");
|
|
gp_message ("debugXL", $subr_name, "src_regex = $src_regex");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Read the file into memory.
|
|
#------------------------------------------------------------------------------
|
|
chomp (@file_contents = <SRC_LISTING>);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Identify the header lines. Make the minimal assumptions.
|
|
#
|
|
# In both cases, the first line after the header has whitespace. This is
|
|
# followed by either one of the following:
|
|
#
|
|
# - <line_no>.
|
|
# - <Function:
|
|
#
|
|
# These are the characteristics we use below.
|
|
#------------------------------------------------------------------------------
|
|
for (my $line_number=0; $line_number <= $#file_contents; $line_number++)
|
|
{
|
|
$input_line = $file_contents[$line_number];
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We found the first source code line. Bail out.
|
|
#------------------------------------------------------------------------------
|
|
if (($input_line =~ /$end_src1_header_regex/) or
|
|
($input_line =~ /$end_src2_header_regex/))
|
|
{
|
|
gp_message ("debugXL", $subr_name, "header time is over - hit source line");
|
|
gp_message ("debugXL", $subr_name, "line_number = $line_number");
|
|
gp_message ("debugXL", $subr_name, "input_line = $input_line");
|
|
last;
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# Store the header lines in the html structure.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$modified_line = "<i>" . $input_line . "</i>";
|
|
push (@modified_html, $modified_line);
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# We know the source code starts at this index value:
|
|
#------------------------------------------------------------------------------
|
|
$start_all_source = scalar (@modified_html);
|
|
gp_message ("debugXL", $subr_name, "source starts at start_all_source = $start_all_source");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Scan the file to identify where the target source starts and ends.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "search for target function $routine");
|
|
$start_tracking = $FALSE;
|
|
$found_target = $FALSE;
|
|
for (my $line_number=0; $line_number <= $#file_contents; $line_number++)
|
|
{
|
|
$input_line = $file_contents[$line_number];
|
|
|
|
gp_message ("debugXL", $subr_name, "[$line_number] $input_line");
|
|
|
|
if ($input_line =~ /$function_regex/)
|
|
{
|
|
if (defined ($1) and defined ($2))
|
|
{
|
|
$func_name_in_src_file = $2;
|
|
my $msg = "found a function - name = $func_name_in_src_file";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
if ($start_tracking)
|
|
{
|
|
$start_tracking = $FALSE;
|
|
$end_target_source = $line_number - 1;
|
|
my $msg = "end_target_source = $end_target_source";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
last;
|
|
}
|
|
|
|
if ($func_name_in_src_file eq $routine)
|
|
{
|
|
$found_target = $TRUE;
|
|
$start_tracking = $TRUE;
|
|
$start_target_source = $line_number;
|
|
|
|
gp_message ("debugXL", $subr_name, "found target function $routine");
|
|
gp_message ("debugXL", $subr_name, "function_name = $2 routine = $routine");
|
|
gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
|
|
gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "parsing line $input_line";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is not supposed to happen, but it is not a fatal error either. The
|
|
# hyperlinks related to this function will not work, so a warning is issued.
|
|
# A message is issued both in debug mode, and as a warning.
|
|
#------------------------------------------------------------------------------
|
|
if (not $found_target)
|
|
{
|
|
my $msg;
|
|
gp_message ("debug", $subr_name, "target function $routine not found");
|
|
|
|
$msg = "function $routine not found in $base - " .
|
|
"links to source code involving this function will not work";
|
|
gp_message ("warning", $subr_name, $msg);
|
|
|
|
return ($found_target);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Catch the line number of the last function.
|
|
#------------------------------------------------------------------------------
|
|
if ($start_tracking)
|
|
{
|
|
$end_target_source = $#file_contents;
|
|
}
|
|
gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
|
|
gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source");
|
|
gp_message ("debugXL", $subr_name, "end_target_source = $end_target_source");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We now have the index range for the function of interest and will parse it.
|
|
# Since we already handled the first line with the function marker, we start
|
|
# with the line following.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Find the hot source lines and store them.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "determine the maximum metric values");
|
|
for (my $line_number=$start_target_source+1; $line_number <= $end_target_source; $line_number++)
|
|
{
|
|
$input_line = $file_contents[$line_number];
|
|
gp_message ("debugXL", $subr_name, " $line_number : check input_line = $input_line");
|
|
|
|
if ( $input_line =~ /$hot_lines_regex/ )
|
|
{
|
|
gp_message ("debugXL", $subr_name, " $line_number : found a hot line");
|
|
#------------------------------------------------------------------------------
|
|
# We found a hot line and the metric fields are stored in $2. We turn this
|
|
# string into an array and add it as a row to hot_source_lines.
|
|
#------------------------------------------------------------------------------
|
|
$hot_line = $1;
|
|
$metric_values = $2;
|
|
|
|
gp_message ("debugXL", $subr_name, "hot_line = $hot_line");
|
|
gp_message ("debugXL", $subr_name, "metric_values = $metric_values");
|
|
|
|
my @metrics = split (" ", $metric_values);
|
|
push (@hot_source_lines, [@metrics]);
|
|
}
|
|
gp_message ("debugXL", $subr_name, " $line_number : completed check for hot line");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Transpose the array with the hot lines. This means each row has all the
|
|
# values for a metrict and it makes it easier to determine the maximum values.
|
|
#------------------------------------------------------------------------------
|
|
for my $row (keys @hot_source_lines)
|
|
{
|
|
my $msg = "row[" . $row . "] = ";
|
|
for my $col (keys @{$hot_source_lines[$row]})
|
|
{
|
|
$msg .= "$hot_source_lines[$row][$col] ";
|
|
$transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col];
|
|
}
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Print the maximum metric values found. Each row contains the data for a
|
|
# different metric.
|
|
#------------------------------------------------------------------------------
|
|
for my $row (keys @transposed_hot_lines)
|
|
{
|
|
my $msg = "row[" . $row . "] = ";
|
|
for my $col (keys @{$transposed_hot_lines[$row]})
|
|
{
|
|
$msg .= "$transposed_hot_lines[$row][$col] ";
|
|
}
|
|
gp_message ("debugXL", $subr_name, "hot lines = $msg");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Determine the maximum value for each metric.
|
|
#------------------------------------------------------------------------------
|
|
for my $row (keys @transposed_hot_lines)
|
|
{
|
|
my $max_val = 0;
|
|
for my $col (keys @{$transposed_hot_lines[$row]})
|
|
{
|
|
$max_val = max ($transposed_hot_lines[$row][$col], $max_val);
|
|
}
|
|
#------------------------------------------------------------------------------
|
|
# Convert to a floating point number.
|
|
#------------------------------------------------------------------------------
|
|
if ($max_val =~ /$integer_only_regex/)
|
|
{
|
|
$max_val = sprintf ("%f", $max_val);
|
|
}
|
|
push (@max_metric_values, $max_val);
|
|
}
|
|
|
|
for my $metric (keys @max_metric_values)
|
|
{
|
|
my $msg = "$input_filename max_metric_values[$metric] = " .
|
|
$max_metric_values[$metric];
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process those functions that are not the current target.
|
|
#------------------------------------------------------------------------------
|
|
$modified_html_ref = process_non_target_source ($start_all_source,
|
|
$start_target_source-1,
|
|
$src_times_regex,
|
|
$function_regex,
|
|
$number_of_metrics,
|
|
\@file_contents,
|
|
\@modified_html);
|
|
@modified_html = @{ $modified_html_ref };
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is the core part to process the information for the target function.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debugXL", $subr_name, "parse and process the target source");
|
|
$modified_html_ref = process_target_source ($start_target_source,
|
|
$end_target_source,
|
|
$routine,
|
|
\@max_metric_values,
|
|
$src_times_regex,
|
|
$function2_regex,
|
|
$number_of_metrics,
|
|
\@file_contents,
|
|
\@modified_html);
|
|
@modified_html = @{ $modified_html_ref };
|
|
|
|
if ($end_target_source < $#file_contents)
|
|
{
|
|
$modified_html_ref = process_non_target_source ($end_target_source+1,
|
|
$#file_contents,
|
|
$src_times_regex,
|
|
$function_regex,
|
|
$number_of_metrics,
|
|
\@file_contents,
|
|
\@modified_html);
|
|
@modified_html = @{ $modified_html_ref };
|
|
}
|
|
|
|
gp_message ("debug", $subr_name, "completed reading source");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Add an extra line with diagnostics.
|
|
#
|
|
# TBD: The same is done in generate_dis_html but should be done only once.
|
|
#------------------------------------------------------------------------------
|
|
if ($hp_value > 0)
|
|
{
|
|
my $rounded_percentage = sprintf ("%.1f", $hp_value);
|
|
$threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>";
|
|
}
|
|
else
|
|
{
|
|
$threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>";
|
|
}
|
|
|
|
$html_home = ${ generate_home_link ("left") };
|
|
$html_end = ${ terminate_html_document () };
|
|
|
|
push (@modified_html, "</pre>");
|
|
push (@modified_html, "<br>");
|
|
push (@modified_html, $threshold_line);
|
|
push (@modified_html, $html_home);
|
|
push (@modified_html, "<br>");
|
|
push (@modified_html, $g_html_credits_line);
|
|
push (@modified_html, $html_end);
|
|
|
|
for my $i (0 .. $#modified_html)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]");
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Write the generated HTML text to file.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (0 .. $#modified_html)
|
|
{
|
|
print NEW_HTML "$modified_html[$i]" . "\n";
|
|
}
|
|
close (NEW_HTML);
|
|
close (SRC_LISTING);
|
|
|
|
return ($found_target);
|
|
|
|
} #-- End of subroutine process_source
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process the source lines for the target function.
|
|
#------------------------------------------------------------------------------
|
|
sub process_target_source
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($start_scan, $end_scan, $target_function, $max_metric_values_ref,
|
|
$src_times_regex, $function2_regex, $number_of_metrics,
|
|
$file_contents_ref, $modified_html_ref) = @_;
|
|
|
|
my @file_contents = @{ $file_contents_ref };
|
|
my @modified_html = @{ $modified_html_ref };
|
|
my @max_metric_values = @{ $max_metric_values_ref };
|
|
|
|
my @components = ();
|
|
|
|
my $colour_coded_line;
|
|
my $colour_coded_line_ref;
|
|
my $hot_line;
|
|
my $input_line;
|
|
my $line_id;
|
|
my $modified_line;
|
|
my $metric_values;
|
|
my $src_code_line;
|
|
my $src_line_no;
|
|
|
|
gp_message ("debug", $subr_name, "parse and process the core loop");
|
|
|
|
for (my $line_number=$start_scan; $line_number <= $end_scan; $line_number++)
|
|
{
|
|
$input_line = $file_contents[$line_number];
|
|
|
|
#------------------------------------------------------------------------------
|
|
# We need to replace the "<" symbol in the code by "<".
|
|
#------------------------------------------------------------------------------
|
|
$input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
|
|
|
|
$line_id = extract_source_line_number ($src_times_regex,
|
|
$function2_regex,
|
|
$number_of_metrics,
|
|
$input_line);
|
|
|
|
gp_message ("debug", $subr_name, "line_number = $line_number : input_line = $input_line line_id = $line_id");
|
|
|
|
if ($input_line =~ /$function2_regex/)
|
|
#------------------------------------------------------------------------------
|
|
# Found the function marker.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if (defined ($1) and defined ($2))
|
|
{
|
|
my $func_name_in_file = $2;
|
|
my $spaces = $1;
|
|
my $boldface = $TRUE;
|
|
gp_message ("debug", $subr_name, "function_name = $2");
|
|
my $function_line = "<Function: " . $func_name_in_file . ">";
|
|
my $color_function_name = color_string (
|
|
$function_line,
|
|
$boldface,
|
|
$g_html_color_scheme{"target_function_name"});
|
|
my $ftag;
|
|
if (exists ($g_function_tag_id{$target_function}))
|
|
{
|
|
$ftag = $g_function_tag_id{$target_function};
|
|
gp_message ("debug", $subr_name, "target_function = $target_function ftag = $ftag");
|
|
}
|
|
else
|
|
{
|
|
my $msg = "no ftag found for $target_function";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
$modified_line = "<a id=\"" . $ftag . "\"></a>";
|
|
$modified_line .= $spaces . "<i>" . $color_function_name . "</i>";
|
|
}
|
|
}
|
|
elsif ($input_line =~ /$src_times_regex/)
|
|
#------------------------------------------------------------------------------
|
|
# This is a line with metric values.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("debug", $subr_name, "input line has metrics");
|
|
|
|
$hot_line = $1;
|
|
$metric_values = $2;
|
|
$src_line_no = $3;
|
|
$src_code_line = $4;
|
|
|
|
gp_message ("debug", $subr_name, "hot_line = $hot_line");
|
|
gp_message ("debug", $subr_name, "metric_values = $metric_values");
|
|
gp_message ("debug", $subr_name, "src_line_no = $src_line_no");
|
|
gp_message ("debug", $subr_name, "src_code_line = $src_code_line");
|
|
|
|
if ($hot_line eq "##")
|
|
#------------------------------------------------------------------------------
|
|
# Highlight the most expensive line.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
@components = split (" ", $input_line, 1+$number_of_metrics+2);
|
|
$modified_line = set_background_color_string (
|
|
$input_line,
|
|
$g_html_color_scheme{"background_color_hot"});
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Highlight those lines close enough to the most expensive line.
|
|
#------------------------------------------------------------------------------
|
|
@components = split (" ", $input_line, $number_of_metrics + 2);
|
|
for my $i (0 .. $number_of_metrics-1)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "$line_number : time check components[$i] = $components[$i]");
|
|
}
|
|
|
|
$colour_coded_line_ref = check_metric_values ($metric_values, \@max_metric_values);
|
|
|
|
$colour_coded_line = $ {$colour_coded_line_ref};
|
|
if ($colour_coded_line)
|
|
{
|
|
gp_message ("debugXL", $subr_name, "$line_number : change background colour modified_line = $modified_line");
|
|
$modified_line = set_background_color_string ($input_line, $g_html_color_scheme{"background_color_lukewarm"});
|
|
}
|
|
else
|
|
{
|
|
$modified_line = "<a id=\"line_" . $line_id . "\"></a>";
|
|
$modified_line .= "$input_line";
|
|
}
|
|
}
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# This is a regular line that is not modified.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Add an id.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "$line_number : input line is a regular line");
|
|
$modified_line = "<a id=\"line_" . $line_id . "\"></a>";
|
|
$modified_line .= "$input_line";
|
|
}
|
|
gp_message ("debug", $subr_name, "$line_number : mod = $modified_line");
|
|
push (@modified_html, $modified_line);
|
|
}
|
|
|
|
return (\@modified_html);
|
|
|
|
} #-- End of subroutine process_target_source
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Process the options. Set associated variables and check the options for
|
|
# correctness. For example, detect if conflicting options have been set.
|
|
#------------------------------------------------------------------------------
|
|
sub process_user_options
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($exp_dir_list_ref) = @_;
|
|
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
|
|
my %ignored_metrics = ();
|
|
|
|
my $error_code;
|
|
my $message;
|
|
|
|
my $outputdir;
|
|
|
|
my $target_cmd;
|
|
my $rm_output_msg;
|
|
my $mkdir_output_msg;
|
|
my $time_percentage_multiplier;
|
|
my $process_all_functions;
|
|
|
|
my $option_errors = 0;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The -o and -O options are mutually exclusive.
|
|
#------------------------------------------------------------------------------
|
|
my $define_new_output_dir = $g_user_settings{"output"}{"defined"};
|
|
my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"};
|
|
my $dir_o_option = $g_user_settings{"output"}{"current_value"};
|
|
my $dir_O_option = $g_user_settings{"overwrite"}{"current_value"};
|
|
|
|
if ($define_new_output_dir and $overwrite_output_dir)
|
|
{
|
|
my $msg;
|
|
|
|
$msg = "the -o/--output and -O/--overwrite options are both set, " .
|
|
"but are mutually exclusive";
|
|
push (@g_user_input_errors, $msg);
|
|
|
|
$msg = "(setting for -o = $dir_o_option, " .
|
|
"setting for -O = $dir_O_option)";
|
|
push (@g_user_input_errors, $msg);
|
|
|
|
$option_errors++;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Define the quiet mode. While this is an on/off keyword in the input, we
|
|
# use a boolean in the remainder, because it reads easier.
|
|
#------------------------------------------------------------------------------
|
|
my $quiet_value = $g_user_settings{"quiet"}{"current_value"};
|
|
$g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# In quiet mode, all verbose, warnings and debug messages are suppressed.
|
|
#------------------------------------------------------------------------------
|
|
if ($g_quiet)
|
|
{
|
|
$g_user_settings{"verbose"}{"current_value"} = "off";
|
|
$g_user_settings{"warnings"}{"current_value"} = "off";
|
|
$g_user_settings{"debug"}{"current_value"} = "off";
|
|
$g_verbose = $FALSE;
|
|
$g_warnings = $FALSE;
|
|
my $debug_off = "off";
|
|
my $ignore_value = set_debug_size (\$debug_off);
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# Get the verbose mode.
|
|
#------------------------------------------------------------------------------
|
|
my $verbose_value = $g_user_settings{"verbose"}{"current_value"};
|
|
$g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE;
|
|
#------------------------------------------------------------------------------
|
|
# Get the warning mode.
|
|
#------------------------------------------------------------------------------
|
|
my $warning_value = $g_user_settings{"warnings"}{"current_value"};
|
|
$g_warnings = ($warning_value eq "on") ? $TRUE : $FALSE;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The value for HP should be in the interval (0,100]. We already enforced
|
|
# the number to be positive, but the limits have not been checked yet.
|
|
#------------------------------------------------------------------------------
|
|
my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
|
|
|
|
if (($hp_value < 0) or ($hp_value > 100))
|
|
{
|
|
my $msg = "the value for the highlight percentage is set to $hp_value, ";
|
|
$msg .= "but must be in the range [0, 100]";
|
|
push (@g_user_input_errors, $msg);
|
|
|
|
$option_errors++;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The value for TP should be in the interval (0,100]. We already enforced
|
|
# the number to be positive, but the limits have not been checked yet.
|
|
#------------------------------------------------------------------------------
|
|
my $tp_value = $g_user_settings{"threshold_percentage"}{"current_value"};
|
|
|
|
if (($tp_value < 0) or ($tp_value > 100))
|
|
{
|
|
my $msg = "the value for the total percentage is set to $tp_value, " .
|
|
"but must be in the range (0, 100]";
|
|
push (@g_user_input_errors, $message);
|
|
|
|
$option_errors++;
|
|
}
|
|
else
|
|
{
|
|
$time_percentage_multiplier = $tp_value/100.0;
|
|
|
|
# Ruud if (($TIME_PERCENTAGE_MULTIPLIER*100.) >= 100.)
|
|
|
|
if ($tp_value == 100)
|
|
{
|
|
$process_all_functions = $TRUE; # ensure that all routines are handled
|
|
}
|
|
else
|
|
{
|
|
$process_all_functions = $FALSE;
|
|
}
|
|
|
|
my $txt;
|
|
$txt = "value of time_percentage_multiplier = " .
|
|
$time_percentage_multiplier;
|
|
gp_message ("debugM", $subr_name, $txt);
|
|
$txt = "value of process_all_functions = " .
|
|
($process_all_functions ? "TRUE" : "FALSE");
|
|
gp_message ("debugM", $subr_name, $txt);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# If imetrics has been set, split the list into the individual metrics that
|
|
# need to be excluded. The associated hash called $ignore_metrics has the
|
|
# to be excluded metrics as an index. The value of $TRUE assigned does not
|
|
# really matter.
|
|
#------------------------------------------------------------------------------
|
|
my @candidate_ignored_metrics;
|
|
|
|
if ($g_user_settings{"ignore_metrics"}{"defined"})
|
|
{
|
|
@candidate_ignored_metrics =
|
|
split (":", $g_user_settings{"ignore_metrics"}{"current_value"});
|
|
}
|
|
for my $metric (@candidate_ignored_metrics)
|
|
{
|
|
# TBD: bug? $ignored_metrics{$metric} = $FALSE;
|
|
$ignored_metrics{$metric} = $TRUE;
|
|
}
|
|
for my $metric (keys %ignored_metrics)
|
|
{
|
|
my $txt = "ignored_metrics{$metric} = $ignored_metrics{$metric}";
|
|
gp_message ("debugM", $subr_name, $txt);
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the experiment directories exist.
|
|
#------------------------------------------------------------------------------
|
|
for my $i (0 .. $#exp_dir_list)
|
|
{
|
|
if (-d $exp_dir_list[$i])
|
|
{
|
|
my $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]);
|
|
$exp_dir_list[$i] = $abs_path_dir;
|
|
my $txt = "directory $exp_dir_list[$i] exists";
|
|
gp_message ("debugM", $subr_name, $txt);
|
|
}
|
|
else
|
|
{
|
|
my $msg = "directory $exp_dir_list[$i] does not exist";
|
|
|
|
push (@g_user_input_errors, $msg);
|
|
$option_errors++;
|
|
}
|
|
}
|
|
|
|
return ($option_errors, \%ignored_metrics, $outputdir,
|
|
$time_percentage_multiplier, $process_all_functions,
|
|
\@exp_dir_list);
|
|
|
|
} #-- End of subroutine process_user_options
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This is a hopefully temporary routine to disable/ignore selected user
|
|
# settings. As the functionality expands, this list will get shorter.
|
|
#------------------------------------------------------------------------------
|
|
sub reset_selected_settings
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
$g_locale_settings{"decimal_separator"} = "\\.";
|
|
$g_locale_settings{"convert_to_dot"} = $FALSE;
|
|
$g_user_settings{func_limit}{current_value} = 1000000;
|
|
|
|
gp_message ("debug", $subr_name, "reset selected settings");
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine reset_selected_settings
|
|
|
|
#------------------------------------------------------------------------------
|
|
# There may be various different visibility characters in a metric definition.
|
|
# For example: e+%CPI.
|
|
#
|
|
# Internally we use a normalized definition that only uses the dot (e.g.
|
|
# e.CPI) as an index into the description structure.
|
|
#
|
|
# Here we reduce the incoming metric definition to the normalized form, look
|
|
# up the text, and return a pointer to it.
|
|
#------------------------------------------------------------------------------
|
|
sub retrieve_metric_description
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($metric_name_ref, $metric_description_ref) = @_;
|
|
|
|
my $metric_name = ${ $metric_name_ref };
|
|
my %metric_description = %{ $metric_description_ref };
|
|
|
|
my $description;
|
|
my $normalized_metric;
|
|
|
|
$metric_name =~ /([ei])([\.\+%]+)(.*)/;
|
|
|
|
if (defined ($1) and defined ($3))
|
|
{
|
|
$normalized_metric = $1 . "." . $3;
|
|
}
|
|
else
|
|
{
|
|
my $msg = "metric $metric_name has an unknown format";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
if (defined ($metric_description{$normalized_metric}))
|
|
{
|
|
$description = $metric_description{$normalized_metric};
|
|
}
|
|
else
|
|
{
|
|
my $msg = "description for normalized metric $normalized_metric not found";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
return (\$description);
|
|
|
|
} #-- End of subroutine retrieve_metric_description
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD.
|
|
#------------------------------------------------------------------------------
|
|
sub rnumerically
|
|
{
|
|
my ($f1,$f2);
|
|
if ($a =~ /^([^\d]*)(\d+)/)
|
|
{
|
|
$f1 = int ($2);
|
|
if ($b=~ /^([^\d]*)(\d+)/)
|
|
{
|
|
$f2 = int ($2);
|
|
$f1 == $f2 ? 0 : ($f1 > $f2 ? -1 : +1);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
return ($b <=> $a);
|
|
}
|
|
} #-- End of subroutine rnumerically
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Remove - not used any longer.
|
|
# Set the architecture and associated regular expressions.
|
|
#------------------------------------------------------------------------------
|
|
sub set_arch_and_regexes
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($arch_uname) = @_;
|
|
|
|
my $architecture_supported;
|
|
|
|
gp_message ("debug", $subr_name, "arch_uname = $arch_uname");
|
|
|
|
if ($arch_uname eq "x86_64")
|
|
{
|
|
#x86/x64 hardware uses jump
|
|
$architecture_supported = $TRUE;
|
|
# $arch='x64';
|
|
# $regex=':\s+(j).*0x[0-9a-f]+';
|
|
# $subexp='(\[\s*)(0x[0-9a-f]+)';
|
|
# $linksubexp='(\[\s*)(0x[0-9a-f]+)';
|
|
gp_message ("debug", $subr_name, "detected $arch_uname hardware");
|
|
|
|
$architecture_supported = $TRUE;
|
|
$g_arch_specific_settings{"arch_supported"} = $TRUE;
|
|
$g_arch_specific_settings{"arch"} = 'x64';
|
|
$g_arch_specific_settings{"regex"} = ':\s+(j).*0x[0-9a-f]+';
|
|
$g_arch_specific_settings{"subexp"} = '(\[\s*)(0x[0-9a-f]+)';
|
|
$g_arch_specific_settings{"linksubexp"} = '(\[\s*)(0x[0-9a-f]+)';
|
|
}
|
|
#-------------------------------------------------------------------------------
|
|
# TBD: Remove the elsif block
|
|
#-------------------------------------------------------------------------------
|
|
elsif ($arch_uname=~m/sparc/s)
|
|
{
|
|
#sparc hardware uses branch
|
|
$architecture_supported = $FALSE;
|
|
# $arch='sparc';
|
|
# $regex=':\s+(c|b|fb).*0x[0-9a-f]+\s*$';
|
|
# $subexp='(\s*)(0x[0-9a-f]+)\s*$';
|
|
# $linksubexp='(\s*)(0x[0-9a-f]+\s*$)';
|
|
# gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch - this is no longer supported");
|
|
$architecture_supported = $FALSE;
|
|
$g_arch_specific_settings{arch_supported} = $FALSE;
|
|
$g_arch_specific_settings{arch} = 'sparc';
|
|
$g_arch_specific_settings{regex} = ':\s+(c|b|fb).*0x[0-9a-f]+\s*$';
|
|
$g_arch_specific_settings{subexp} = '(\s*)(0x[0-9a-f]+)\s*$';
|
|
$g_arch_specific_settings{linksubexp} = '(\s*)(0x[0-9a-f]+\s*$)';
|
|
}
|
|
else
|
|
{
|
|
$architecture_supported = $FALSE;
|
|
gp_message ("debug", $subr_name, "detected $arch_uname hardware - this not supported; limited functionality");
|
|
}
|
|
|
|
return ($architecture_supported);
|
|
|
|
} #-- End of subroutine set_arch_and_regexes
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Set the background color of the input string.
|
|
#
|
|
# For supported colors, see:
|
|
# https://www.w3schools.com/colors/colors_names.asp
|
|
#------------------------------------------------------------------------------
|
|
sub set_background_color_string
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_string, $color) = @_;
|
|
|
|
my $background_color_string;
|
|
my $msg;
|
|
|
|
$msg = "color = $color input_string = $input_string";
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
$background_color_string = "<span style='background-color: " . $color .
|
|
"'>" . $input_string . "</span>";
|
|
|
|
$msg = "color = $color background_color_string = " .
|
|
$background_color_string;
|
|
gp_message ("debugXL", $subr_name, $msg);
|
|
|
|
return ($background_color_string);
|
|
|
|
} #-- End of subroutine set_background_color_string
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Set the g_debug_size structure for a given value for "size". Also set the
|
|
# value in $g_user_settings{"debug"}{"current_value"}
|
|
#------------------------------------------------------------------------------
|
|
sub set_debug_size
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($debug_value_ref) = @_;
|
|
|
|
my $debug_value = lc (${ $debug_value_ref });
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Regardless of the value, the debug settings are defined here.
|
|
#------------------------------------------------------------------------------
|
|
$g_user_settings{"debug"}{"defined"} = $TRUE;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# By default, set the value to "on", but correct below if needed.
|
|
#------------------------------------------------------------------------------
|
|
$g_user_settings{"debug"}{"current_value"} = "on";
|
|
|
|
if (($debug_value eq "on") or ($debug_value eq "s"))
|
|
{
|
|
$g_debug_size{"on"} = $TRUE;
|
|
$g_debug_size{"s"} = $TRUE;
|
|
}
|
|
elsif ($debug_value eq "m")
|
|
{
|
|
$g_debug_size{"on"} = $TRUE;
|
|
$g_debug_size{"s"} = $TRUE;
|
|
$g_debug_size{"m"} = $TRUE;
|
|
}
|
|
elsif ($debug_value eq "l")
|
|
{
|
|
$g_debug_size{"on"} = $TRUE;
|
|
$g_debug_size{"s"} = $TRUE;
|
|
$g_debug_size{"m"} = $TRUE;
|
|
$g_debug_size{"l"} = $TRUE;
|
|
}
|
|
elsif ($debug_value eq "xl")
|
|
{
|
|
$g_debug_size{"on"} = $TRUE;
|
|
$g_debug_size{"s"} = $TRUE;
|
|
$g_debug_size{"m"} = $TRUE;
|
|
$g_debug_size{"l"} = $TRUE;
|
|
$g_debug_size{"xl"} = $TRUE;
|
|
}
|
|
else
|
|
#------------------------------------------------------------------------------
|
|
# Any other value is considered to disable debugging.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$g_user_settings{"debug"}{"current_value"} = "off";
|
|
$g_debug_size{"on"} = $FALSE;
|
|
$g_debug_size{"s"} = $FALSE;
|
|
$g_debug_size{"m"} = $FALSE;
|
|
$g_debug_size{"l"} = $FALSE;
|
|
$g_debug_size{"xl"} = $FALSE;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Activate in case of an emergency :-)
|
|
#------------------------------------------------------------------------------
|
|
## if ($g_debug_size{$debug_value})
|
|
## {
|
|
## for my $i (keys %g_debug_size)
|
|
## {
|
|
## print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n";
|
|
## }
|
|
## }
|
|
|
|
return (0);
|
|
|
|
} #-- End of subroutine set_debug_size
|
|
|
|
#------------------------------------------------------------------------------
|
|
# This subroutine defines the default metrics.
|
|
#------------------------------------------------------------------------------
|
|
sub set_default_metrics
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($outfile1, $ignored_metrics_ref) = @_;
|
|
|
|
my %ignored_metrics = %{ $ignored_metrics_ref };
|
|
|
|
my %metric_description = ();
|
|
my %metric_found = ();
|
|
|
|
my $detail_metrics;
|
|
my $detail_metrics_system;
|
|
|
|
my $call_metrics = "";
|
|
my $summary_metrics = "";
|
|
|
|
open (METRICS, "<", $outfile1)
|
|
or die ("Unable to open metrics file $outfile1 for reading - '$!'");
|
|
gp_message ("debug", $subr_name, "opened $outfile1 for reading");
|
|
|
|
while (<METRICS>)
|
|
{
|
|
my $metric_line = $_;
|
|
chomp ($metric_line);
|
|
|
|
gp_message ("debug", $subr_name,"the value of metric_line = $metric_line");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Decode the metric part of the input line. If a valid line, return the
|
|
# metric components. Otherwise return "skipped" in the metric_spec field.
|
|
#------------------------------------------------------------------------------
|
|
my ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description) = extract_metric_specifics ($metric_line);
|
|
|
|
gp_message ("debug", $subr_name, "metric_spec = $metric_spec");
|
|
gp_message ("debug", $subr_name, "metric_flavor = $metric_flavor");
|
|
|
|
if ($metric_spec eq "skipped")
|
|
#------------------------------------------------------------------------------
|
|
# Not a valid input line.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
gp_message ("debug", $subr_name, "skipped line: $metric_line");
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# A valid metric field has been found.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "metric_name = $metric_name");
|
|
gp_message ("debug", $subr_name, "metric_description = $metric_description");
|
|
|
|
# if (exists ($IMETRICS{$m})){
|
|
if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{$metric_name}))
|
|
{
|
|
gp_message ("debug", $subr_name, "user requested to ignore metric $metric_name");
|
|
next;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Only the exclusive metric is selected.
|
|
#------------------------------------------------------------------------------
|
|
if ($metric_flavor eq "e")
|
|
{
|
|
$metric_found{$metric_spec} = $TRUE;
|
|
$metric_description{$metric_spec} = $metric_description;
|
|
|
|
# TBD: remove the -AO:
|
|
gp_message ("debug", $subr_name,"-AO metric_description{$metric_spec} = $metric_description{$metric_spec}");
|
|
|
|
$summary_metrics .= $metric_spec.":";
|
|
$call_metrics .= "a.".$metric_name.":";
|
|
}
|
|
}
|
|
}
|
|
close (METRICS);
|
|
|
|
chop ($call_metrics);
|
|
chop ($summary_metrics);
|
|
|
|
$detail_metrics = $summary_metrics;
|
|
$detail_metrics_system = $summary_metrics;
|
|
|
|
return (\%metric_description, \%metric_found,
|
|
$summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics);
|
|
|
|
} #-- End of subroutine set_default_metrics
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Set various system specific variables. These depend upon both the processor
|
|
# architecture and OS. The values are stored in global structure
|
|
# g_arch_specific_settings.
|
|
#------------------------------------------------------------------------------
|
|
sub set_system_specific_variables
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($arch_uname, $arch_uname_s) = @_;
|
|
|
|
my $elf_arch;
|
|
my $read_elf_cmd;
|
|
my $elf_support;
|
|
my $architecture_supported;
|
|
my $arch;
|
|
my $regex;
|
|
my $subexp;
|
|
my $linksubexp;
|
|
|
|
if ($arch_uname eq "x86_64")
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# x86/x64 hardware uses jump
|
|
#------------------------------------------------------------------------------
|
|
$architecture_supported = $TRUE;
|
|
$arch = 'x64';
|
|
$regex =':\s+(j).*0x[0-9a-f]+';
|
|
$subexp ='(\[\s*)(0x[0-9a-f]+)';
|
|
$linksubexp ='(\[\s*)(0x[0-9a-f]+)';
|
|
|
|
# gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch");
|
|
|
|
$g_arch_specific_settings{"arch_supported"} = $TRUE;
|
|
$g_arch_specific_settings{"arch"} = 'x64';
|
|
#------------------------------------------------------------------------------
|
|
# Define the regular expressions to parse branch instructions.
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Need much more than these
|
|
#------------------------------------------------------------------------------
|
|
$g_arch_specific_settings{"regex"} = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)';
|
|
$g_arch_specific_settings{"subexp"} = '(0x[0-9a-f]+)';
|
|
$g_arch_specific_settings{"linksubexp"} = '(\s*)(0x[0-9a-f]+)';
|
|
}
|
|
else
|
|
{
|
|
$architecture_supported = $FALSE;
|
|
$g_arch_specific_settings{"arch_supported"} = $FALSE;
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD Ruud: need to handle this better
|
|
#------------------------------------------------------------------------------
|
|
if ($arch_uname_s eq "Linux")
|
|
{
|
|
$elf_arch = $arch_uname_s;
|
|
$read_elf_cmd = $g_mapped_cmds{"readelf"};
|
|
|
|
if ($read_elf_cmd eq "road_to_nowhere")
|
|
{
|
|
$elf_support = $FALSE;
|
|
}
|
|
else
|
|
{
|
|
$elf_support = $TRUE;
|
|
}
|
|
gp_message ("debugXL", $subr_name, "elf_support = $elf_support read_elf_cmd = $read_elf_cmd elf_arch = $elf_arch");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("abort", $subr_name, "the $arch_uname_s operating system is not supported");
|
|
}
|
|
|
|
return ($architecture_supported, $elf_arch, $elf_support);
|
|
|
|
} #-- End of subroutine set_system_specific_variables
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD
|
|
#------------------------------------------------------------------------------
|
|
sub set_title
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($function_info_ref, $func, $from_where) = @_ ;
|
|
|
|
my $msg;
|
|
my @function_info = @{$function_info_ref};
|
|
my $filename = $func ;
|
|
|
|
my $base;
|
|
my $first_line;
|
|
my $src_file;
|
|
my $RI;
|
|
my $the_title;
|
|
my $routine = "?";
|
|
my $DIS;
|
|
my $SRC;
|
|
|
|
chomp ($filename);
|
|
|
|
$base = get_basename ($filename);
|
|
|
|
gp_message ("debug", $subr_name, "from_where = $from_where");
|
|
gp_message ("debug", $subr_name, "base = $base filename = $filename");
|
|
|
|
if ($from_where eq "process source")
|
|
{
|
|
if ($base =~ /^file\.(\d+)\.src\.txt$/)
|
|
{
|
|
if (defined ($1))
|
|
{
|
|
$RI = $1;
|
|
}
|
|
else
|
|
{
|
|
$msg = "unexpected error encountered parsing $filename";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
$the_title = "Source";
|
|
}
|
|
elsif ($from_where eq "disassembly")
|
|
{
|
|
if ($base =~ /^file\.(\d+)\.dis$/)
|
|
{
|
|
if (defined ($1))
|
|
{
|
|
$RI = $1;
|
|
}
|
|
else
|
|
{
|
|
$msg = "unexpected error encountered parsing $filename";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
}
|
|
$the_title = "Disassembly";
|
|
}
|
|
else
|
|
{
|
|
$msg = "called from unknown routine - $from_where";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
if (defined ($function_info[$RI]{"routine"}))
|
|
{
|
|
$routine = $function_info[$RI]{"routine"};
|
|
}
|
|
|
|
if ($from_where eq "process source")
|
|
{
|
|
my $is_empty = is_file_empty ($filename);
|
|
|
|
if ($is_empty)
|
|
{
|
|
$src_file = "";
|
|
}
|
|
else
|
|
{
|
|
open ($SRC, "<", $filename)
|
|
or die ("$subr_name - unable to open source file $filename for reading:'$!'");
|
|
gp_message ("debug", $subr_name, "opened file $filename for reading");
|
|
|
|
$first_line = <$SRC>;
|
|
chomp ($first_line);
|
|
|
|
close ($SRC);
|
|
|
|
gp_message ("debug", $subr_name, "first_line = $first_line");
|
|
|
|
if ($first_line =~ /^Source\s+file:\s+([^\s]+)/)
|
|
{
|
|
$src_file = $1
|
|
}
|
|
else
|
|
{
|
|
$src_file = "";
|
|
}
|
|
}
|
|
}
|
|
elsif ($from_where eq "disassembly")
|
|
{
|
|
open ($DIS, "<", $filename)
|
|
or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'");
|
|
gp_message ("debug", $subr_name, "opened file $filename for reading");
|
|
|
|
$first_line = <$DIS>;
|
|
close ($DIS);
|
|
|
|
if ($first_line =~ /^Source\s+file:\s+([^\s]+)/)
|
|
{
|
|
$src_file = "$1"
|
|
}
|
|
else
|
|
{
|
|
$src_file = "";
|
|
}
|
|
}
|
|
|
|
if (length ($routine))
|
|
{
|
|
$the_title .= " $routine";
|
|
}
|
|
|
|
if (length ($src_file))
|
|
{
|
|
if ($src_file ne "(unknown)")
|
|
{
|
|
$the_title .= " ($src_file)";
|
|
}
|
|
else
|
|
{
|
|
$the_title .= " $src_file";
|
|
}
|
|
}
|
|
|
|
return ($the_title);
|
|
|
|
} #-- End of subroutine set_title
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Handles where the output should go. If needed, a directory is # created
|
|
# where the results will go.
|
|
#------------------------------------------------------------------------------
|
|
sub set_up_output_directory
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my $error_code;
|
|
my $message;
|
|
my $mkdir_output_msg;
|
|
my $option_errors;
|
|
my $outputdir = "does_not_exist_yet";
|
|
my $rm_output_msg;
|
|
my $target_cmd;
|
|
|
|
my $define_new_output_dir = $g_user_settings{"output"}{"defined"};
|
|
my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"};
|
|
|
|
$option_errors = 0;
|
|
|
|
if ((not $define_new_output_dir) and (not $overwrite_output_dir))
|
|
#------------------------------------------------------------------------------
|
|
# If neither -o or -O are set, find the next number to be used in the name for
|
|
# the default output directory.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my $dir_id = 1;
|
|
while (-d "display.".$dir_id.".html")
|
|
{ $dir_id++; }
|
|
$outputdir = "display.".$dir_id.".html";
|
|
}
|
|
elsif ($define_new_output_dir)
|
|
#------------------------------------------------------------------------------
|
|
# The output directory is defined with the -o option.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$outputdir = $g_user_settings{"output"}{"current_value"};
|
|
}
|
|
elsif ($overwrite_output_dir)
|
|
#------------------------------------------------------------------------------
|
|
# The output directory is defined with the -O option.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
$outputdir = $g_user_settings{"overwrite"}{"current_value"};
|
|
}
|
|
|
|
#------------------------------------------------------------------------------
|
|
# The name of the output directory is known and we can proceed.
|
|
#------------------------------------------------------------------------------
|
|
gp_message ("debug", $subr_name, "the target output directory is $outputdir");
|
|
|
|
if (-d $outputdir)
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The -o option is used, but the directory already exists.
|
|
#------------------------------------------------------------------------------
|
|
if ($define_new_output_dir)
|
|
{
|
|
$message = "directory $outputdir already exists";
|
|
$message .= " (use the -O option to overwrite an existing directory)";
|
|
push (@g_user_input_errors, $message);
|
|
|
|
$option_errors++;
|
|
|
|
return ($option_errors, $outputdir);
|
|
}
|
|
elsif ($overwrite_output_dir)
|
|
#------------------------------------------------------------------------------
|
|
# It is a bit risky to remove this directory and so we proceed with caution.
|
|
# What if the user decides to call it "*" e.g. "-O \*" for example? While this
|
|
# should have been caught when processing the options, we still like to
|
|
# be very cautious here before executing /bin/rm -rf.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if ($outputdir eq "*")
|
|
{
|
|
$message = "it is not allowed to use * as a value for the -O option";
|
|
push (@g_user_input_errors, $message);
|
|
|
|
$option_errors++;
|
|
|
|
return ($option_errors, $outputdir);
|
|
}
|
|
else
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# The output directory exists, but it is okay to overwrite it. It is
|
|
# removed here and created again below.
|
|
#------------------------------------------------------------------------------
|
|
$target_cmd = $g_mapped_cmds{"rm"} . " -rf " . $outputdir;
|
|
($error_code, $rm_output_msg) = execute_system_cmd ($target_cmd);
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
gp_message ("error", $subr_name, $rm_output_msg);
|
|
gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir");
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "directory $outputdir has been removed");
|
|
}
|
|
}
|
|
}
|
|
} #-- End of if-check for $outputdir
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# When we get here, the fatal scenarios have been cleared and the name for
|
|
# $outputdir is known. Time to create it. Note that recursive creation is
|
|
# supported and umask controls the access permissions.
|
|
#-------------------------------------------------------------------------------
|
|
$target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir;
|
|
($error_code, $mkdir_output_msg) = execute_system_cmd ($target_cmd);
|
|
|
|
if ($error_code != 0)
|
|
{
|
|
my $msg = "a fatal problem occurred when creating directory $outputdir";
|
|
gp_message ("abort", $subr_name, $msg);
|
|
}
|
|
else
|
|
{
|
|
gp_message ("debug", $subr_name, "created output directory $outputdir");
|
|
}
|
|
|
|
return ($option_errors, $outputdir);
|
|
|
|
} #-- End of subroutine set_up_output_directory
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Routine to generate webfriendly names
|
|
#------------------------------------------------------------------------------
|
|
sub tag_name
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($target_name) = @_;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Keeps track how many names have been tagged already.
|
|
#------------------------------------------------------------------------------
|
|
state $S_total_tagged_names = 0;
|
|
|
|
my $unique_name;
|
|
|
|
gp_message ("debug", $subr_name, "target_name on entry = $target_name");
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Undo conversion of < in to <
|
|
#------------------------------------------------------------------------------
|
|
|
|
#------------------------------------------------------------------------------
|
|
# TBD: Legacy - What is going on here and is this really needed?!
|
|
# We need to replace the "<" symbol in the code by "<".
|
|
#------------------------------------------------------------------------------
|
|
$target_name =~ s/$g_html_less_than_regex/$g_less_than_regex/g;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Remove inlining info
|
|
#------------------------------------------------------------------------------
|
|
$target_name =~ s/, instructions from source file.*//;
|
|
|
|
if (defined $g_tagged_names{$target_name})
|
|
{
|
|
gp_message ("debug", $subr_name, "target_name = $target_name is already defined: $g_tagged_names{$target_name}");
|
|
gp_message ("debug", $subr_name, "target_name on return = $target_name");
|
|
return ($g_tagged_names{$target_name});
|
|
}
|
|
else
|
|
{
|
|
$unique_name = "ftag".$S_total_tagged_names;
|
|
$S_total_tagged_names++;
|
|
$g_tagged_names{$target_name} = $unique_name;
|
|
gp_message ("debug", $subr_name, "target_name = $target_name is new and added: g_tagged_names{$target_name} = $g_tagged_names{$target_name}");
|
|
gp_message ("debug", $subr_name, "target_name on return = $target_name");
|
|
return ($unique_name);
|
|
}
|
|
|
|
} #-- End of subroutine tag_name
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Generate a string to terminate the HTML document.
|
|
#------------------------------------------------------------------------------
|
|
sub terminate_html_document
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my $html_line;
|
|
|
|
$html_line = "</body>\n";
|
|
$html_line .= "</html>";
|
|
|
|
return (\$html_line);
|
|
|
|
} #-- End of subroutine terminate_html_document
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Perform some basic checks to ensure the input data is consistent. This part
|
|
# could be refined and expanded over time. For example by using a checksum
|
|
# mechanism to verify the consistency of the executables.
|
|
#-------------------------------------------------------------------------------
|
|
sub verify_consistency_experiments
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($exp_dir_list_ref) = @_;
|
|
|
|
my @exp_dir_list = @{ $exp_dir_list_ref };
|
|
|
|
my $executable_name;
|
|
my $full_path_executable_name;
|
|
my $ref_executable_name;
|
|
|
|
my $first_exp_dir = $TRUE;
|
|
my $count_differences = 0;
|
|
|
|
#-------------------------------------------------------------------------------
|
|
# Enforce that the full path names to the executable are the same. This could
|
|
# be overkill and a checksum approach would be more flexible.
|
|
#-------------------------------------------------------------------------------
|
|
for my $full_exp_dir (@exp_dir_list)
|
|
{
|
|
my $exp_dir = get_basename ($full_exp_dir);
|
|
gp_message ("debug", $subr_name, "exp_dir = $exp_dir");
|
|
if ($first_exp_dir)
|
|
{
|
|
$first_exp_dir = $FALSE;
|
|
$ref_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
|
|
gp_message ("debug", $subr_name, "ref_executable_name = $ref_executable_name");
|
|
next;
|
|
}
|
|
$full_path_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
|
|
gp_message ("debug", $subr_name, "full_path_executable_name = $full_path_executable_name");
|
|
|
|
if ($full_path_executable_name ne $ref_executable_name)
|
|
{
|
|
$count_differences++;
|
|
gp_message ("debug", $subr_name, "$full_path_executable_name does not match $ref_executable_name");
|
|
}
|
|
}
|
|
|
|
$executable_name = get_basename ($ref_executable_name);
|
|
|
|
return ($count_differences, $executable_name);
|
|
|
|
} #-- End of subroutine verify_consistency_experiments
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the input item is valid for the data type specified. Validity is
|
|
# verified in the context of gprofng. The definition for the metrics is a
|
|
# good example of that.
|
|
#------------------------------------------------------------------------------
|
|
sub verify_if_input_is_valid
|
|
{
|
|
my $subr_name = get_my_name ();
|
|
|
|
my ($input_item, $data_type) = @_;
|
|
|
|
my $return_value = $FALSE;
|
|
|
|
#------------------------------------------------------------------------------
|
|
# These value are allowed to be case insensitive, so we convert to lower
|
|
# case first.
|
|
#------------------------------------------------------------------------------
|
|
if (($data_type eq "onoff") or ($data_type eq "size"))
|
|
{
|
|
$input_item = lc ($input_item);
|
|
}
|
|
|
|
if ($data_type eq "metrics")
|
|
#------------------------------------------------------------------------------
|
|
# A gprofng metric definition. Either consists of "default" only, or starts
|
|
# with e or i, followed by one or more from the set {.,%,!,+} and a keyword.
|
|
# This pattern may be repeated with a ":" as the separator.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my @metric_list = split (":", $input_item);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the pattern is valid. If not, bail out and return $FALSE.
|
|
#------------------------------------------------------------------------------
|
|
for my $metric (@metric_list)
|
|
{
|
|
if ($metric =~ /^default$|^[ei]*[\.%\!\+]+[a-z]*$/)
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
else
|
|
{
|
|
$return_value = $FALSE;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
elsif ($data_type eq "metric_names")
|
|
#------------------------------------------------------------------------------
|
|
# A gprofng metric definition but without the flavour and visibility . Either
|
|
# the name consists of "default" only, or a keyword with lowercase letters
|
|
# only. This pattern may be repeated with a ":" as the separator.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
my @metric_list = split (":", $input_item);
|
|
|
|
#------------------------------------------------------------------------------
|
|
# Check if the pattern is valid. If not, bail out and return $FALSE.
|
|
#------------------------------------------------------------------------------
|
|
for my $metric (@metric_list)
|
|
{
|
|
if ($metric =~ /^default$|^[a-z]*$/)
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
else
|
|
{
|
|
$return_value = $FALSE;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
elsif ($data_type eq "path")
|
|
#------------------------------------------------------------------------------
|
|
# This can be almost anything, including "/" and "."
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if ($input_item =~ /^[\w\/\.]*$/)
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
}
|
|
elsif ($data_type eq "boolean")
|
|
{
|
|
#------------------------------------------------------------------------------
|
|
# This is TRUE (=1) or FALSE (0).
|
|
#------------------------------------------------------------------------------
|
|
if ($input_item =~ /^[01]$/)
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
}
|
|
elsif ($data_type eq "onoff")
|
|
#------------------------------------------------------------------------------
|
|
# This is either "on" OR "off".
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if ($input_item =~ /^on$|^off$/)
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
}
|
|
elsif ($data_type eq "size")
|
|
#------------------------------------------------------------------------------
|
|
# Supported values are "on", "off", "s", "m", "l", OR "xl".
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if ($input_item =~ /^on$|^off$|^s$|^m$|^l$|^xl$/)
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
}
|
|
elsif ($data_type eq "pinteger")
|
|
#------------------------------------------------------------------------------
|
|
# This is a positive integer.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if ($input_item =~ /^\d*$/)
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
}
|
|
elsif ($data_type eq "integer")
|
|
#------------------------------------------------------------------------------
|
|
# This is a positive or negative integer.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if ($input_item =~ /^\-?\d*$/)
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
}
|
|
elsif ($data_type eq "pfloat")
|
|
#------------------------------------------------------------------------------
|
|
# This is a positive floating point number, but we accept a positive integer
|
|
# number as well.
|
|
#
|
|
# TBD: Note that we use the "." here. Maybe should support a "," too.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if (($input_item =~ /^\d*\.\d*$/) or ($input_item =~ /^\d*$/))
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
}
|
|
elsif ($data_type eq "float")
|
|
#------------------------------------------------------------------------------
|
|
# This is a positive or negative floating point number, but we accept an
|
|
# integer number as well.
|
|
#
|
|
# TBD: Note that we use the "." here. Maybe should support a "," too.
|
|
#------------------------------------------------------------------------------
|
|
{
|
|
if (($input_item =~ /^\-?\d*\.\d*$/) or ($input_item =~ /^\-?\d*$/))
|
|
{
|
|
$return_value = $TRUE;
|
|
}
|
|
}
|
|
else
|
|
{
|
|
my $msg = "the $data_type data type for input $input_item is not supported";
|
|
gp_message ("assertion", $subr_name, $msg);
|
|
}
|
|
|
|
return ($return_value);
|
|
|
|
} #-- End of subroutine verify_if_input_is_valid
|