1#!/usr/bin/env perl 2# Copyright (C) 2021 Free Software Foundation, Inc. 3# Contributed by Oracle. 4# 5# This file is part of GNU Binutils. 6# 7# This program is free software; you can redistribute it and/or modify 8# it under the terms of the GNU General Public License as published by 9# the Free Software Foundation; either version 3, or (at your option) 10# any later version. 11# 12# This program is distributed in the hope that it will be useful, 13# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# GNU General Public License for more details. 16# 17# You should have received a copy of the GNU General Public License 18# along with this program; if not, write to the Free Software 19# Foundation, 51 Franklin Street - Fifth Floor, Boston, 20# MA 02110-1301, USA. 21 22use strict; 23use warnings; 24use feature qw (state); 25use File::stat; 26 27#------------------------------------------------------------------------------ 28# Check as early as possible if the version of Perl used is supported. 29#------------------------------------------------------------------------------ 30INIT 31{ 32 my $perl_minimal_version_supported = version->parse ("5.10.0")->normal; 33 my $perl_current_version = version->parse ("$]")->normal; 34 35 if ($perl_current_version lt $perl_minimal_version_supported) 36 { 37 my $msg; 38 39 $msg = "Error: minimum Perl release required: "; 40 $msg .= $perl_minimal_version_supported; 41 $msg .= " current: "; 42 $msg .= $perl_current_version; 43 $msg .= "\n"; 44 45 print $msg; 46 47 exit (1); 48 } 49} #-- End of INIT 50 51#------------------------------------------------------------------------------ 52# Poor man's version of a boolean. 53#------------------------------------------------------------------------------ 54my $TRUE = 1; 55my $FALSE = 0; 56 57#------------------------------------------------------------------------------ 58# Used to ensure correct alignment of columns. 59#------------------------------------------------------------------------------ 60my $g_max_length_first_metric; 61 62#------------------------------------------------------------------------------ 63# This variable contains the path used to execute $GP_DISPAY_TEXT. 64#------------------------------------------------------------------------------ 65my $g_path_to_tools; 66 67#------------------------------------------------------------------------------- 68# Code debugging flag 69#------------------------------------------------------------------------------- 70my $g_test_code = $FALSE; 71 72#------------------------------------------------------------------------------- 73# GPROFNG commands and files used. 74#------------------------------------------------------------------------------- 75my $GP_DISPLAY_TEXT = "gp-display-text"; 76 77my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log"; 78my $g_gp_error_logfile = $GP_DISPLAY_TEXT.".stderr.log"; 79 80#------------------------------------------------------------------------------ 81# Global variables. 82#------------------------------------------------------------------------------ 83my $g_addressing_mode = "64 bit"; 84 85#------------------------------------------------------------------------------ 86# The global regex section. 87# 88# First step towards consolidating all regexes. 89#------------------------------------------------------------------------------ 90 my $g_less_than_regex = '<'; 91 my $g_html_less_than_regex = '<'; 92 my $g_endbr_inst_regex = 'endbr[32|64]'; 93 94#------------------------------------------------------------------------------ 95# These are the regex's used. 96#------------------------------------------------------------------------------ 97#------------------------------------------------------------------------------ 98# Disassembly analysis 99#------------------------------------------------------------------------------ 100 my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; 101 my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; 102 my $g_function_call_v2_regex = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; 103 104#------------------------------------------------------------------------------ 105# Convenience. These map the on/off value to $TRUE/$FALSE to make the code 106# easier to read. For example: "if ($g_verbose)" as opposed to the following: 107# "if ($verbose_setting eq "on"). 108#------------------------------------------------------------------------------ 109my $g_verbose; 110my $g_warnings; 111my $g_quiet; 112 113my $g_first_metric; 114 115my $binutils_version; 116my $driver_cmd; 117my $tool_name; 118my $version_info; 119 120my %g_mapped_cmds = (); 121 122#------------------------------------------------------------------------------ 123# TBD All warning messages are collected and are accessible through the main 124# page. 125#------------------------------------------------------------------------------ 126my @g_warning_messages = (); 127 128#------------------------------------------------------------------------------ 129# Contains the names that have already been tagged. This is a global 130# structure because otherwise the code would get much more complicated. 131#------------------------------------------------------------------------------ 132my %g_tagged_names = (); 133 134#------------------------------------------------------------------------------ 135# TBD Remove the use of these structures. No longer used. 136#------------------------------------------------------------------------------ 137my %g_function_tag_id = (); 138my $g_context = 5; # Defines the range of scan 139 140my $g_default_setting_lang = "en-US.UTF-8"; 141my %g_exp_dir_meta_data; 142 143my @g_user_input_errors = (); 144 145my $g_html_credits_line; 146 147my $g_warn_keyword = "Input warning: "; 148my $g_error_keyword = "Input error: "; 149 150my %g_function_occurrences = (); 151my %g_map_function_to_index = (); 152my %g_multi_count_function = (); 153my %g_function_view_all = (); 154my @g_full_function_view_table = (); 155 156my @g_html_experiment_stats = (); 157 158#------------------------------------------------------------------------------- 159# These structures contain the information printed in the function views. 160#------------------------------------------------------------------------------- 161my $g_header_lines; 162 163my @g_html_function_name = (); 164 165#------------------------------------------------------------------------------- 166# TBD: This variable may not be needed and replaced by tp_value 167my $thresh = 0; 168#------------------------------------------------------------------------------- 169 170#------------------------------------------------------------------------------- 171# Define the driver command, tool name and version number. 172#------------------------------------------------------------------------------- 173$driver_cmd = "gprofng display html"; 174$tool_name = "gp-display-html"; 175#$binutils_version = "2.38.50"; 176$binutils_version = "BINUTILS_VERSION"; 177$version_info = $tool_name . " GNU binutils version " . $binutils_version; 178 179#------------------------------------------------------------------------------- 180 181#------------------------------------------------------------------------------- 182# Define several key data structures. 183#------------------------------------------------------------------------------- 184my %g_user_settings = 185 ( 186 output => { option => "-o" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE}, 187 overwrite => { option => "-O" , no_of_arguments => 1, data_type => "path" , current_value => undef, defined => $FALSE}, 188 calltree => { option => "-ct", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, 189 func_limit => { option => "-fl", no_of_arguments => 1, data_type => "pinteger", current_value => 500 , defined => $FALSE}, 190 highlight_percentage => { option => "-hp", no_of_arguments => 1, data_type => "pfloat" , current_value => 90.0 , defined => $FALSE}, 191 threshold_percentage => { option => "-tp", no_of_arguments => 1, data_type => "pfloat" , current_value => 100.0 , defined => $FALSE}, 192 default_metrics => { option => "-dm", no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, 193 ignore_metrics => { option => "-im", no_of_arguments => 1, data_type => "metric_names", current_value => undef, defined => $FALSE}, 194 verbose => { option => "--verbose" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, 195 warnings => { option => "--warnings" , no_of_arguments => 1, data_type => "onoff" , current_value => "on" , defined => $FALSE}, 196 debug => { option => "--debug" , no_of_arguments => 1, data_type => "size" , current_value => "off" , defined => $FALSE}, 197 quiet => { option => "--quiet" , no_of_arguments => 1, data_type => "onoff" , current_value => "off" , defined => $FALSE}, 198 ); 199 200my %g_debug_size = 201 ( 202 "on" => $FALSE, 203 "s" => $FALSE, 204 "m" => $FALSE, 205 "l" => $FALSE, 206 "xl" => $FALSE, 207 ); 208 209my %local_system_config = 210 ( 211 kernel_name => "undefined", 212 nodename => "undefined", 213 kernel_release => "undefined", 214 kernel_version => "undefined", 215 machine => "undefined", 216 processor => "undefined", 217 hardware_platform => "undefined", 218 operating_system => "undefined", 219 hostname_current => "undefined", 220 ); 221 222# Note that we use single quotes here, because regular expressions wreak havoc otherwise. 223 224my %g_arch_specific_settings = 225 ( 226 arch_supported => $FALSE, 227 arch => 'undefined', 228 regex => 'undefined', 229 subexp => 'undefined', 230 linksubexp => 'undefined', 231 ); 232 233my %g_locale_settings = ( 234 LANG => "en_US.UTF-8", 235 decimal_separator => "\\.", 236 covert_to_dot => $FALSE 237); 238 239#------------------------------------------------------------------------------ 240# See this page for a nice overview with the colors: 241# https://www.w3schools.com/colors/colors_groups.asp 242#------------------------------------------------------------------------------ 243 244my %g_html_color_scheme = ( 245 "control_flow" => "Brown", 246 "target_function_name" => "Red", 247 "non_target_function_name" => "BlueViolet", 248 "background_color_hot" => "PeachPuff", 249 "background_color_lukewarm" => "LemonChiffon", 250 "link_outside_range" => "Crimson", 251 "error_message" => "LightPink", 252 "background_color_page" => "White", 253# "background_color_page" => "LightGray", 254 "background_selected_sort" => "LightSlateGray", 255 "index" => "Lavender", 256); 257 258#------------------------------------------------------------------------------ 259# These are the base names for the HTML files that are generated. 260#------------------------------------------------------------------------------ 261my %g_html_base_file_name = ( 262 "caller_callee" => "caller-callee", 263 "disassembly" => "dis", 264 "experiment_info" => "experiment-info", 265 "function_view" => "function-view-sorted", 266 "index" => "index", 267 "source" => "src", 268 "warnings" => "warnings", 269); 270 271#------------------------------------------------------------------------------ 272# This is cosmetic, but helps with the scoping of variables. 273#------------------------------------------------------------------------------ 274 main (); 275 276 exit (0); 277 278#------------------------------------------------------------------------------ 279# This is the driver part of the program. 280#------------------------------------------------------------------------------ 281sub main 282{ 283 my $subr_name = get_my_name (); 284 285#------------------------------------------------------------------------------ 286# The name of the configuration file. 287#------------------------------------------------------------------------------ 288 my $rc_file_name = ".gp-display-html.rc"; 289 290#------------------------------------------------------------------------------ 291# OS commands executed and search paths. 292#------------------------------------------------------------------------------ 293 my @selected_os_cmds = qw (rm mv cat hostname locale which printenv ls 294 uname readelf mkdir); 295 my @search_paths_os_cmds = qw ( 296 /usr/bin 297 /bin 298 /usr/local/bin 299 /usr/local/sbin 300 /usr/sbin 301 /sbin 302 ); 303 304#------------------------------------------------------------------------------ 305# TBD: Eliminate these. 306#------------------------------------------------------------------------------ 307 my $ARCHIVES_MAP_NAME; 308 my $ARCHIVES_MAP_VADDR; 309 310#------------------------------------------------------------------------------ 311# Local structures (hashes and arrays). 312#------------------------------------------------------------------------------ 313 my @exp_dir_list; # List with experiment directories 314 my @metrics_data; 315 316 my %function_address_info = (); 317 my $function_address_info_ref; 318 319 my @function_info = (); 320 my $function_info_ref; 321 322 my %function_address_and_index = (); 323 my $function_address_and_index_ref; 324 325 my %addressobjtextm = (); 326 my $addressobjtextm_ref; 327 328 my %addressobj_index = (); 329 my $addressobj_index_ref; 330 331 my %LINUX_vDSO = (); 332 my $LINUX_vDSO_ref; 333 334 my %function_view_structure = (); 335 my $function_view_structure_ref; 336 337 my %elf_rats = (); 338 my $elf_rats_ref; 339 340#------------------------------------------------------------------------------ 341# Local variables. 342#------------------------------------------------------------------------------ 343 my $abs_path_outputdir; 344 my $archive_dir_not_empty; 345 my $base_va_executable; 346 my $executable_name; 347 my $exp_dir_list_ref; 348 my $found_exp_dir; 349 my $ignore_value; 350 my $message; 351 my $number_of_metrics; 352 my $va_executable_in_hex; 353 354 my $failed_command_mappings; 355 my $option_errors; 356 my $total_user_errors; 357 358 my $script_pc_metrics; 359 my $dir_check_errors; 360 my $consistency_errors; 361 my $outputdir; 362 my $return_code; 363 364 my $decimal_separator; 365 my $convert_to_dot; 366 my $architecture_supported; 367 my $elf_arch; 368 my $elf_support; 369 my $home_dir; 370 my $elf_loadobjects_found; 371 372 my $rc_file_paths_ref; 373 my @rc_file_paths = (); 374 my $rc_file_errors = 0; 375 376 my @sort_fields = (); 377 my $summary_metrics; 378 my $call_metrics; 379 my $user_metrics; 380 my $system_metrics; 381 my $wall_metrics; 382 my $detail_metrics; 383 my $detail_metrics_system; 384 385 my $pretty_dir_list; 386 387 my %metric_value = (); 388 my %metric_description = (); 389 my %metric_description_reversed = (); 390 my %metric_found = (); 391 my %ignored_metrics = (); 392 393 my $metric_value_ref; 394 my $metric_description_ref; 395 my $metric_found_ref; 396 my $ignored_metrics_ref; 397 398 my @table_execution_stats = (); 399 my $table_execution_stats_ref; 400 401 my $html_first_metric_file_ref; 402 my $html_first_metric_file; 403 404 my $arch; 405 my $subexp; 406 my $linksubexp; 407 408 my $setting_for_LANG; 409 my $time_percentage_multiplier; 410 my $process_all_functions; 411 412 my $selected_archive; 413 414#------------------------------------------------------------------------------ 415# If no options are given, print the help info and exit. 416#------------------------------------------------------------------------------ 417 if ($#ARGV == -1) 418 { 419 $ignore_value = print_help_info (); 420 return (0); 421 } 422 423#------------------------------------------------------------------------------ 424# This part is like a preamble. Before we continue we need to figure out some 425# things that are needed later on. 426#------------------------------------------------------------------------------ 427 428#------------------------------------------------------------------------------ 429# Store the absolute path of the command executed. 430#------------------------------------------------------------------------------ 431 my $location_gp_command = $0; 432 433#------------------------------------------------------------------------------ 434# The very first thing to do is to quickly determine if the user has enabled 435# one of the following options and take action accordingly: 436# --version, --verbose, --debug, --quiet 437# 438# This avoids that there is a gap between the start of the execution and the 439# moment the options are parsed, checked, and interpreted. 440# 441# When parsing the full command line, these options will be more extensively 442# checked and also updated in %g_user_settings 443 444# Note that a confirmation message, if any, is printed here and not when the 445# options are parsed and processed. 446#------------------------------------------------------------------------------ 447 448 $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE; 449 $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE; 450 $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE; 451 452 $ignore_value = early_scan_specific_options (); 453 454#------------------------------------------------------------------------------ 455# The next subroutine is executed early to ensure the OS commands we need are 456# available. 457# 458# This subroutine stores the commands and the full path names as an associative 459# array called "g_mapped_cmds". The command is the key and the value is the full 460# path. For example: ("uname", /usr/bin/uname). 461#------------------------------------------------------------------------------ 462 $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, \@search_paths_os_cmds); 463 464 if ($failed_command_mappings == 0) 465 { 466 gp_message ("debug", $subr_name, "verified the OS commands"); 467 } 468 else 469 { 470 my $msg = "failure in the verification of the OS commands"; 471 gp_message ("assertion", $subr_name, $msg); 472 } 473 474#------------------------------------------------------------------------------ 475# Get the home directory and the locations for the configuration file on the 476# current system. 477#------------------------------------------------------------------------------ 478 ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name); 479 480 @rc_file_paths = @{ $rc_file_paths_ref }; 481 gp_message ("debug", $subr_name, "the home directory is $home_dir"); 482 gp_message ("debugXL", $subr_name, "the search path for the rc file is @rc_file_paths"); 483 484 $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths); 485 486#------------------------------------------------------------------------------ 487# Get the ball rolling. Parse and interpret the configuration file (if any) 488# and the command line options. 489# 490# If either $rc_file_errors or $total_user_errors, or both, are non-zero it 491# means a fatal error has occured. In this case, all error messages are 492# printed and execution is terminated. 493# 494# Note that the verbose, debug, and quiet options can be set in this file. 495# It is a deliberate choice to ignore these for now. The assumption is that 496# the user will not be happy if we ignore the command line settings for a 497# while. 498#------------------------------------------------------------------------------ 499 500 gp_message ("debugXL", $subr_name, "processing of the rc file disabled for now"); 501 502# Temporarily disabled print_table_user_settings ("debugXL", "before function process_rc_file"); 503# Temporarily disabled 504# Temporarily disabled $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref); 505# Temporarily disabled 506# Temporarily disabled if ($rc_file_errors != 0) 507# Temporarily disabled { 508# Temporarily disabled $message = "fatal errors in file $rc_file_name encountered"; 509# Temporarily disabled gp_message ("debugXL", $subr_name, $message); 510# Temporarily disabled } 511# Temporarily disabled 512# Temporarily disabled print_table_user_settings ("debugXL", "after function process_rc_file"); 513 514#------------------------------------------------------------------------------ 515# Get the ball rolling. Parse and interpret the options. Some first checks 516# are performed. 517# 518# Instead of bailing out on the first user error, we capture all errors, print 519# messages and then bail out. This is more user friendly. 520#------------------------------------------------------------------------------ 521 gp_message ("verbose", $subr_name, "Parse the user options"); 522 523 $total_user_errors = 0; 524 525 ($option_errors, $found_exp_dir, $exp_dir_list_ref) = parse_and_check_user_options ( 526 \$#ARGV, 527 \@ARGV); 528 $total_user_errors += $option_errors; 529 530#------------------------------------------------------------------------------ 531# Dynamically load the modules needed. If a module is not available, print 532# an error message and bail out. 533# 534# This call replaces the following: 535# 536# use feature qw (state); 537# use List::Util qw (min max); 538# use Cwd; 539# use File::Basename; 540# use File::stat; 541# use POSIX; 542# use bignum; 543# 544# Note that this check cannot be done earlier, because in case of a missing 545# module, the man page would not be generated if the code ends prematurely 546# in case the --help and --version options are used.. 547#------------------------------------------------------------------------------ 548 my ($module_errors_ref, $missing_modules_ref) = handle_module_availability (); 549 550 my $module_errors = ${ $module_errors_ref }; 551 552 if ($module_errors > 0) 553 { 554 my $msg; 555 556 my $plural_or_single = ($module_errors > 1) ? "modules are" : "module is"; 557 my @missing_modules = @{ $missing_modules_ref }; 558 559 for my $i (0 .. $#missing_modules) 560 { 561 $msg = "module $missing_modules[$i] is missing"; 562 gp_message ("error", $subr_name, $msg); 563 } 564 565 $msg = $module_errors . " " . $plural_or_single . 566 "missing - execution is terminated"; 567 gp_message ("abort", $subr_name, $msg); 568 } 569 570#------------------------------------------------------------------------------ 571# The user options have been taken in. Check for validity and consistency. 572#------------------------------------------------------------------------------ 573 gp_message ("verbose", $subr_name, "Process user options"); 574 575 ($option_errors, $ignored_metrics_ref, $outputdir, 576 $time_percentage_multiplier, $process_all_functions, 577 $exp_dir_list_ref) = process_user_options ($exp_dir_list_ref); 578 579 @exp_dir_list = @{ $exp_dir_list_ref }; 580 %ignored_metrics = %{$ignored_metrics_ref}; 581 582 $total_user_errors += $option_errors; 583 584#------------------------------------------------------------------------------ 585# If no option is given for the output directory, pick a default. Otherwise, 586# if the output directory exists, wipe it clean in case the -O option is used. 587# If not, flag an error because the -o option does not overwrite an existing 588# directory. 589#------------------------------------------------------------------------------ 590 if ($total_user_errors == 0) 591 { 592 ($option_errors, $outputdir) = set_up_output_directory (); 593 $abs_path_outputdir = cwd () . "/" . $outputdir; 594 $total_user_errors += $option_errors; 595 } 596 597 if ($total_user_errors == 0) 598 { 599 gp_message ("debug", $subr_name, "the output directory is $outputdir"); 600 } 601 else 602 { 603#------------------------------------------------------------------------------ 604# All command line errors and warnings are printed here. 605#------------------------------------------------------------------------------ 606 my $plural_or_single = ($total_user_errors > 1) ? "errors have" : "error has"; 607 $message = $g_error_keyword; 608 $message .= $total_user_errors; 609 if ($rc_file_errors > 0) 610 { 611 $message .= " additional"; 612 } 613 $message .= " fatal input $plural_or_single been detected:"; 614 gp_message ("error", $subr_name, $message); 615 for my $key (keys @g_user_input_errors) 616 { 617 gp_message ("error", $subr_name, "$g_error_keyword $g_user_input_errors[$key]"); 618 } 619 } 620 621#------------------------------------------------------------------------------ 622# Bail out in case fatal errors have occurred. 623#------------------------------------------------------------------------------ 624 if ( ($rc_file_errors + $total_user_errors) > 0) 625 { 626 my $msg = "the current values for the user controllable settings"; 627 print_user_settings ("debug", $msg); 628 629 gp_message ("abort", $subr_name, "execution terminated"); 630 } 631 else 632 { 633 my $msg = "after parsing the user options, the final values are"; 634 print_user_settings ("debug", $msg); 635 636#------------------------------------------------------------------------------ 637# TBD: Enable once all planned features have been implemented and tested. 638#------------------------------------------------------------------------------ 639# Temporarily disabled $msg = "the final values for the user controllable settings"; 640# Temporarily disabled print_table_user_settings ("verbose", $msg); 641 } 642 643#------------------------------------------------------------------------------ 644# Print a list with the experiment directory names 645#------------------------------------------------------------------------------ 646 $pretty_dir_list = build_pretty_dir_list (\@exp_dir_list); 647 648 my $plural = ($#exp_dir_list > 0) ? "directories are" : "directory is"; 649 650 gp_message ("verbose", $subr_name, "The experiment " . $plural . ":"); 651 gp_message ("verbose", $subr_name, $pretty_dir_list); 652 653#------------------------------------------------------------------------------ 654# Set up the first entry with the meta data for the experiments. This field 655# contains the absolute paths to the experiment directories. 656#------------------------------------------------------------------------------ 657 for my $exp_dir (@exp_dir_list) 658 { 659 my ($filename, $directory_path, $ignore_suffix) = fileparse ($exp_dir); 660 gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); 661 gp_message ("debug", $subr_name, "filename = $filename"); 662 gp_message ("debug", $subr_name, "directory_path = $directory_path"); 663 $g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path; 664 } 665 666#------------------------------------------------------------------------------ 667# Check whether the experiment directories are valid. If not, it is a fatal 668# error. 669# Upon successful return, one directory has been selected to be used in the 670# remainder. This is not always the correct thing to do, but is the same as 671# the original code. In due time this should be addressed though. 672#------------------------------------------------------------------------------ 673 ($dir_check_errors, $archive_dir_not_empty, $selected_archive, 674 $elf_rats_ref) = check_validity_exp_dirs ($exp_dir_list_ref); 675 676 if ($dir_check_errors) 677 { 678 gp_message ("abort", $subr_name, "execution terminated"); 679 } 680 else 681 { 682 gp_message ("verbose", $subr_name, "The experiment directories have been verified and are valid"); 683 } 684 685 %elf_rats = %{$elf_rats_ref}; 686 687#------------------------------------------------------------------------------- 688# Now that we know the map.xml file(s) are present, we can scan these and get 689# the required information. This includes setting the base virtual address. 690#------------------------------------------------------------------------------- 691 $ignore_value = determine_base_virtual_address ($exp_dir_list_ref); 692 693#------------------------------------------------------------------------------ 694# Check whether the experiment directories are consistent. 695#------------------------------------------------------------------------------ 696 ($consistency_errors, $executable_name) = verify_consistency_experiments ($exp_dir_list_ref); 697 698 if ($consistency_errors == 0) 699 { 700 gp_message ("verbose", $subr_name, "The experiment directories are consistent"); 701 } 702 else 703 { 704 gp_message ("abort", $subr_name, "number of consistency errors detected: $consistency_errors"); 705 } 706 707#------------------------------------------------------------------------------ 708# The directories are consistent. We can now set the base virtual address of 709# the executable. 710#------------------------------------------------------------------------------ 711 $base_va_executable = $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"}; 712 713 gp_message ("debug", $subr_name, "executable_name = $executable_name"); 714 gp_message ("debug", $subr_name, "selected_archive = $selected_archive"); 715 gp_message ("debug", $subr_name, "base_va_executable = $base_va_executable"); 716 717#------------------------------------------------------------------------------ 718# The $GP_DISPLAY_TEXT tool is critical and has to be available in order 719# to proceed. 720# This subroutine only returns a value if the tool can be found." 721#------------------------------------------------------------------------------ 722 $g_path_to_tools = ${ check_availability_tool (\$location_gp_command)}; 723 724 $GP_DISPLAY_TEXT = $g_path_to_tools . $GP_DISPLAY_TEXT; 725 726 gp_message ("debug", $subr_name, "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT"); 727 728#------------------------------------------------------------------------------ 729# Check if $GP_DISPLAY_TEXT is executable for user, group, and other. 730# If not, print a warning only, since this may not be fatal but could 731# potentially lead to issues later on. 732#------------------------------------------------------------------------------ 733 if (not is_file_executable ($GP_DISPLAY_TEXT)) 734 { 735 my $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and other"; 736 gp_message ("warning", $subr_name, $msg); 737 } 738 739#------------------------------------------------------------------------------ 740# Find out what the decimal separator is, as set by the user. 741#------------------------------------------------------------------------------ 742 ($return_code, $decimal_separator, $convert_to_dot) = 743 determine_decimal_separator (); 744 745 if ($return_code == 0) 746 { 747 my $txt = "decimal separator is $decimal_separator " . 748 "(conversion to dot is " . 749 ($convert_to_dot == $TRUE ? "enabled" : "disabled").")"; 750 gp_message ("debugXL", $subr_name, $txt); 751 } 752 else 753 { 754 my $msg = "the decimal separator cannot be determined - set to $decimal_separator"; 755 gp_message ("warning", $subr_name, $msg); 756 } 757 758#------------------------------------------------------------------------------ 759# Collect and store the system information. 760#------------------------------------------------------------------------------ 761 gp_message ("verbose", $subr_name, "Collect system information and adapt settings"); 762 763 $return_code = get_system_config_info (); 764 765#------------------------------------------------------------------------------ 766# The 3 variables below are used in the remainder. 767# 768# The output from "uname -p" is recommended to be used for the ISA. 769#------------------------------------------------------------------------------ 770 my $hostname_current = $local_system_config{hostname_current}; 771 my $arch_uname_s = $local_system_config{kernel_name}; 772 my $arch_uname = $local_system_config{processor}; 773 774 gp_message ("debug", $subr_name, "set hostname_current = $hostname_current"); 775 gp_message ("debug", $subr_name, "set arch_uname_s = $arch_uname_s"); 776 gp_message ("debug", $subr_name, "set arch_uname = $arch_uname"); 777 778#------------------------------------------------------------------------------- 779# This function also sets the values in "g_arch_specific_settings". This 780# includes several definitions of regular expressions. 781#------------------------------------------------------------------------------- 782 ($architecture_supported, $elf_arch, $elf_support) = 783 set_system_specific_variables ($arch_uname, $arch_uname_s); 784 785 gp_message ("debug", $subr_name, "architecture_supported = $architecture_supported"); 786 gp_message ("debug", $subr_name, "elf_arch = $elf_arch"); 787 gp_message ("debug", $subr_name, "elf_support = ".($elf_arch ? "TRUE" : "FALSE")); 788 789 for my $feature (sort keys %g_arch_specific_settings) 790 { 791 gp_message ("debug", $subr_name, "g_arch_specific_settings{$feature} = $g_arch_specific_settings{$feature}"); 792 } 793 794 $arch = $g_arch_specific_settings{"arch"}; 795 $subexp = $g_arch_specific_settings{"subexp"}; 796 $linksubexp = $g_arch_specific_settings{"linksubexp"}; 797 798 $g_locale_settings{"LANG"} = get_LANG_setting (); 799 800 gp_message ("debugXL", $subr_name, "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}"); 801 802#------------------------------------------------------------------------------ 803# Temporarily reset selected settings since these are not yet implemented. 804#------------------------------------------------------------------------------ 805 $ignore_value = reset_selected_settings (); 806 807#------------------------------------------------------------------------------ 808# TBD: Revisit. Is this really necessary? 809#------------------------------------------------------------------------------ 810 811 ($executable_name, $va_executable_in_hex) = check_loadobjects_are_elf ($selected_archive); 812 $elf_loadobjects_found = $TRUE; 813 814# TBD: Hack and those ARCHIVES_ names can be eliminated 815 $ARCHIVES_MAP_NAME = $executable_name; 816 $ARCHIVES_MAP_VADDR = $va_executable_in_hex; 817 gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"); 818 gp_message ("debugXL", $subr_name, "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"); 819 820 gp_message ("debugXL", $subr_name, "after call to check_loadobjects_are_elf forced elf_loadobjects_found = $elf_loadobjects_found"); 821 822 $g_html_credits_line = ${ create_html_credits () }; 823 gp_message ("debugXL", $subr_name, "g_html_credits_line = $g_html_credits_line"); 824#------------------------------------------------------------------------------ 825# Add a "/" to simplify the construction of path names in the remainder. 826# 827# TBD: Push this into a subroutine(s). 828#------------------------------------------------------------------------------ 829 $outputdir = append_forward_slash ($outputdir); 830 831 gp_message ("debug", $subr_name, "prepared outputdir = $outputdir"); 832 833#------------------------------------------------------------------------------ 834#------------------------------------------------------------------------------ 835# ******* TBD: e.system not available on Linux!! 836#------------------------------------------------------------------------------ 837#------------------------------------------------------------------------------ 838 839## my $summary_metrics = 'e.totalcpu'; 840 $detail_metrics = 'e.totalcpu'; 841 $detail_metrics_system = 'e.totalcpu:e.system'; 842 $call_metrics = 'a.totalcpu'; 843 844 my $cmd_options; 845 my $metrics_cmd; 846 847 my $outfile1 = $outputdir ."metrics"; 848 my $outfile2 = $outputdir . "metrictotals"; 849 my $gp_error_file = $outputdir . $g_gp_error_logfile; 850 851#------------------------------------------------------------------------------ 852# Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is 853# to get all the output in files $outfile1 and $outfile2. These are then 854# parsed. 855#------------------------------------------------------------------------------ 856 gp_message ("verbose", $subr_name, "Gather the metrics data from the experiments"); 857 858 $return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1, $outfile2, $gp_error_file); 859 860 if ($return_code != 0) 861 { 862 gp_message ("abort", $subr_name, "execution terminated"); 863 } 864 865#------------------------------------------------------------------------------ 866# TBD: Test this code 867#------------------------------------------------------------------------------ 868 open (METRICS, "<", $outfile1) 869 or die ("$subr_name - unable to open metric value data file $outfile1 for reading: '$!'"); 870 gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); 871 872 chomp (@metrics_data = <METRICS>); 873 close (METRICS); 874 875 for my $i (keys @metrics_data) 876 { 877 gp_message ("debugXL", $subr_name, "metrics_data[$i] = $metrics_data[$i]"); 878 } 879 880#------------------------------------------------------------------------------ 881# Process the generated metrics data. 882#------------------------------------------------------------------------------ 883 if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") 884 885#------------------------------------------------------------------------------ 886# The metrics will be derived from the experiments. 887#------------------------------------------------------------------------------ 888 { 889 gp_message ("verbose", $subr_name, "Process the metrics data"); 890 891 ($metric_value_ref, $metric_description_ref, $metric_found_ref, 892 $user_metrics, $system_metrics, $wall_metrics, 893 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics 894 ) = process_metrics_data ($outfile1, $outfile2, \%ignored_metrics); 895 896 %metric_value = %{ $metric_value_ref }; 897 %metric_description = %{ $metric_description_ref }; 898 %metric_found = %{ $metric_found_ref }; 899 %metric_description_reversed = reverse %metric_description; 900 901 gp_message ("debugXL", $subr_name, "after the call to process_metrics_data"); 902 for my $metric (sort keys %metric_value) 903 { 904 gp_message ("debugXL", $subr_name, "metric_value{$metric} = $metric_value{$metric}"); 905 } 906 for my $metric (sort keys %metric_description) 907 { 908 gp_message ("debugXL", $subr_name, "metric_description{$metric} = $metric_description{$metric}"); 909 } 910 gp_message ("debugXL", $subr_name, "user_metrics = $user_metrics"); 911 gp_message ("debugXL", $subr_name, "system_metrics = $system_metrics"); 912 gp_message ("debugXL", $subr_name, "wall_metrics = $wall_metrics"); 913 } 914 else 915 { 916#------------------------------------------------------------------------------ 917# A default set of metrics will be used. 918# 919# TBD: These should be OS dependent. 920#------------------------------------------------------------------------------ 921 gp_message ("verbose", $subr_name, "Select the set of default metrics"); 922 923 ($metric_description_ref, $metric_found_ref, $summary_metrics, 924 $detail_metrics, $detail_metrics_system, $call_metrics 925 ) = set_default_metrics ($outfile1, \%ignored_metrics); 926 927 928 %metric_description = %{ $metric_description_ref }; 929 %metric_found = %{ $metric_found_ref }; 930 %metric_description_reversed = reverse %metric_description; 931 932 gp_message ("debug", $subr_name, "after the call to set_default_metrics"); 933 934 } 935 936 $number_of_metrics = split (":", $summary_metrics); 937 938 gp_message ("debugXL", $subr_name, "summary_metrics = $summary_metrics"); 939 gp_message ("debugXL", $subr_name, "detail_metrics = $detail_metrics"); 940 gp_message ("debugXL", $subr_name, "detail_metrics_system = $detail_metrics_system"); 941 gp_message ("debugXL", $subr_name, "call_metrics = $call_metrics"); 942 gp_message ("debugXL", $subr_name, "number_of_metrics = $number_of_metrics"); 943 944#------------------------------------------------------------------------------ 945# TBD Find a way to better handle this situation: 946#------------------------------------------------------------------------------ 947 for my $im (keys %metric_found) 948 { 949 gp_message ("debugXL", $subr_name, "metric_found{$im} = $metric_found{$im}"); 950 } 951 for my $im (keys %ignored_metrics) 952 { 953 if (not exists ($metric_found{$im})) 954 { 955 gp_message ("debugXL", $subr_name, "user requested ignored metric (-im) $im does not exist in collected metrics"); 956 } 957 } 958 959#------------------------------------------------------------------------------ 960# Get the information on the experiments. 961#------------------------------------------------------------------------------ 962 gp_message ("verbose", $subr_name, "Generate the experiment information"); 963 964 my $exp_info_file_ref; 965 my $exp_info_file; 966 my $exp_info_ref; 967 my @exp_info; 968 969 my $experiment_data_ref; 970 971 $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list); 972 my @experiment_data = @{ $experiment_data_ref }; 973 974 for my $i (sort keys @experiment_data) 975 { 976 my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " . 977 $experiment_data[$i]{"exp_name_full"}; 978 gp_message ("debugM", $subr_name, $msg); 979 } 980 981 $experiment_data_ref = process_experiment_info ($experiment_data_ref); 982 @experiment_data = @{ $experiment_data_ref }; 983 984 for my $i (sort keys @experiment_data) 985 { 986 for my $fields (sort keys %{ $experiment_data[$i] }) 987 { 988 my $msg = "i = $i experiment_data[$i]{$fields} = " . 989 $experiment_data[$i]{$fields}; 990 gp_message ("debugXL", $subr_name, $msg); 991 } 992 } 993 994 @g_html_experiment_stats = @{ create_exp_info ( 995 \@exp_dir_list, 996 \@experiment_data) }; 997 998 $table_execution_stats_ref = html_generate_exp_summary ( 999 \$outputdir, 1000 \@experiment_data); 1001 @table_execution_stats = @{ $table_execution_stats_ref }; 1002 1003#------------------------------------------------------------------------------ 1004# Get the function overview. 1005#------------------------------------------------------------------------------ 1006 gp_message ("verbose", $subr_name, "Generate the list with functions executed"); 1007 1008 my ($outfile, $sort_fields_ref) = get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir); 1009 1010 @sort_fields = @{$sort_fields_ref}; 1011 1012#------------------------------------------------------------------------------ 1013# Parse the output from the fsummary command and store the relevant data for 1014# all the functions listed there. 1015#------------------------------------------------------------------------------ 1016 1017 gp_message ("verbose", $subr_name, "Analyze and store the relevant function information"); 1018 1019 ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref, 1020 $LINUX_vDSO_ref, $function_view_structure_ref) = get_function_info ($outfile); 1021 1022 @function_info = @{ $function_info_ref }; 1023 %function_address_and_index = %{ $function_address_and_index_ref }; 1024 %addressobjtextm = %{ $addressobjtextm_ref }; 1025 %LINUX_vDSO = %{ $LINUX_vDSO_ref }; 1026 %function_view_structure = %{ $function_view_structure_ref }; 1027 1028 for my $keys (0 .. $#function_info) 1029 { 1030 for my $fields (keys %{$function_info[$keys]}) 1031 { 1032 gp_message ("debugXL", $subr_name,"$keys $fields $function_info[$keys]{$fields}"); 1033 } 1034 } 1035 1036 for my $i (keys %addressobjtextm) 1037 { 1038 gp_message ("debugXL", $subr_name,"addressobjtextm{$i} = $addressobjtextm{$i}"); 1039 } 1040 1041 gp_message ("verbose", $subr_name, "Generate the files with function overviews and the callers-callees information"); 1042 1043 $script_pc_metrics = generate_function_level_info (\@exp_dir_list, 1044 $call_metrics, 1045 $summary_metrics, 1046 $outputdir, 1047 $sort_fields_ref); 1048 1049 gp_message ("verbose", $subr_name, "Preprocess the files with the function level information"); 1050 1051 $ignore_value = preprocess_function_files ( 1052 $metric_description_ref, 1053 $script_pc_metrics, 1054 $outputdir, 1055 \@sort_fields); 1056 1057 gp_message ("verbose", $subr_name, "For each function, generate a set of files"); 1058 1059 ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = process_function_files ( 1060 \@exp_dir_list, 1061 $executable_name, 1062 $time_percentage_multiplier, 1063 $summary_metrics, 1064 $process_all_functions, 1065 $elf_loadobjects_found, 1066 $outputdir, 1067 \@sort_fields, 1068 \@function_info, 1069 \%function_address_and_index, 1070 \%LINUX_vDSO, 1071 \%metric_description, 1072 $elf_arch, 1073 $base_va_executable, 1074 $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, \%elf_rats); 1075 1076 @function_info = @{ $function_info_ref }; 1077 %function_address_info = %{ $function_address_info_ref }; 1078 %addressobj_index = %{ $addressobj_index_ref }; 1079 1080#------------------------------------------------------------------------------------- 1081# Parse the disassembly information and generate the html files. 1082#------------------------------------------------------------------------------------- 1083 gp_message ("verbose", $subr_name, "Parse the disassembly files and generate the html files"); 1084 1085 $ignore_value = parse_dis_files (\$number_of_metrics, \@function_info, 1086 \%function_address_and_index, 1087 \$outputdir, \%addressobj_index); 1088 1089#------------------------------------------------------------------------------------- 1090# Parse the source information and generate the html files. 1091#------------------------------------------------------------------------------------- 1092 gp_message ("verbose", $subr_name, "Parse the source files and generate the html files"); 1093 1094 parse_source_files (\$number_of_metrics, \@function_info, \$outputdir); 1095 1096#------------------------------------------------------------------------------------- 1097# Parse the caller-callee information and generate the html files. 1098#------------------------------------------------------------------------------------- 1099 gp_message ("verbose", $subr_name, "Process the caller-callee information and generate the html file"); 1100 1101#------------------------------------------------------------------------------------- 1102# Generate the caller-callee information. 1103#------------------------------------------------------------------------------------- 1104 $ignore_value = generate_caller_callee ( 1105 \$number_of_metrics, 1106 \@function_info, 1107 \%function_view_structure, 1108 \%function_address_info, 1109 \%addressobjtextm, 1110 \$outputdir); 1111 1112#------------------------------------------------------------------------------------- 1113# Parse the calltree information and generate the html files. 1114#------------------------------------------------------------------------------------- 1115 if ($g_user_settings{"calltree"}{"current_value"} eq "on") 1116 { 1117 my $msg = "Process the call tree information and generate the html file"; 1118 gp_message ("verbose", $subr_name, $msg); 1119 1120 $ignore_value = process_calltree ( 1121 \@function_info, 1122 \%function_address_info, 1123 \%addressobjtextm, 1124 $outputdir); 1125 } 1126 1127#------------------------------------------------------------------------------------- 1128# TBD 1129#------------------------------------------------------------------------------------- 1130 gp_message ("verbose", $subr_name, "Generate the html file with the metrics information"); 1131 1132 $ignore_value = process_metrics ( 1133 $outputdir, 1134 \@sort_fields, 1135 \%metric_description, 1136 \%ignored_metrics); 1137 1138#------------------------------------------------------------------------------------- 1139# Generate the function view html files. 1140#------------------------------------------------------------------------------------- 1141 gp_message ("verbose", $subr_name, "Generate the function view html files"); 1142 1143 $html_first_metric_file_ref = generate_function_view ( 1144 \$outputdir, 1145 \$summary_metrics, 1146 \$number_of_metrics, 1147 \@function_info, 1148 \%function_view_structure, 1149 \%function_address_info, 1150 \@sort_fields, 1151 \@exp_dir_list, 1152 \%addressobjtextm); 1153 1154 $html_first_metric_file = ${ $html_first_metric_file_ref }; 1155 1156 gp_message ("debugXL", $subr_name, "html_first_metric_file = $html_first_metric_file"); 1157 1158 my $html_test = ${ generate_home_link ("left") }; 1159 gp_message ("debugXL", $subr_name, "html_test = $html_test"); 1160 1161 my $number_of_warnings_ref = create_html_warnings_page (\$outputdir); 1162 1163#------------------------------------------------------------------------------------- 1164# Generate the index.html file. 1165#------------------------------------------------------------------------------------- 1166 gp_message ("verbose", $subr_name, "Generate the index.html file"); 1167 1168 $ignore_value = generate_index (\$outputdir, 1169 \$html_first_metric_file, 1170 \$summary_metrics, 1171 \$number_of_metrics, 1172 \@function_info, 1173 \%function_address_info, 1174 \@sort_fields, 1175 \@exp_dir_list, 1176 \%addressobjtextm, 1177 \%metric_description_reversed, 1178 $number_of_warnings_ref, 1179 \@table_execution_stats); 1180 1181#------------------------------------------------------------------------------------- 1182# We're done. In debug mode, print the meta data for the experiment directories. 1183#------------------------------------------------------------------------------------- 1184 $ignore_value = print_meta_data_experiments ("debug"); 1185 1186 my $results_file = $abs_path_outputdir . "/index.html"; 1187 my $prologue_text = "Processing completed - view file $results_file in a browser"; 1188 gp_message ("diag", $subr_name, $prologue_text); 1189 1190 return (0); 1191 1192} #-- End of subroutine main 1193 1194#------------------------------------------------------------------------------ 1195# Print a message after a failure in $GP_DISPLAY_TEXT. 1196#------------------------------------------------------------------------------ 1197sub msg_display_text_failure 1198{ 1199 my $subr_name = get_my_name (); 1200 1201 my ($gp_display_text_cmd, $error_code, $error_file) = @_; 1202 1203 my $msg; 1204 1205 $msg = "error code = $error_code - failure executing the following command:"; 1206 gp_message ("error", $subr_name, $msg); 1207 1208 gp_message ("error", $subr_name, $gp_display_text_cmd); 1209 1210 $msg = "check file $error_file for more details"; 1211 gp_message ("error", $subr_name, $msg); 1212 1213 return (0); 1214 1215} #-- End of subroutine msg_display_text_failure 1216 1217#------------------------------------------------------------------------------ 1218# If it is not present, add a "/" to the name of the argument. This is 1219# intended to be used for the name of the output directory and makes it 1220# easier to construct pathnames. 1221#------------------------------------------------------------------------------ 1222sub append_forward_slash 1223{ 1224 my $subr_name = get_my_name (); 1225 1226 my ($input_string) = @_; 1227 1228 my $length_of_string = length ($input_string); 1229 my $return_string = $input_string; 1230 1231 if (rindex ($input_string, "/") != $length_of_string-1) 1232 { 1233 $return_string .= "/"; 1234 } 1235 1236 return ($return_string); 1237 1238} #-- End of subroutine append_forward_slash 1239 1240#------------------------------------------------------------------------------ 1241# Return a string with a comma separated list of directory names. 1242#------------------------------------------------------------------------------ 1243sub build_pretty_dir_list 1244{ 1245 my $subr_name = get_my_name (); 1246 1247 my ($dir_list_ref) = @_; 1248 1249 my @dir_list = @{ $dir_list_ref}; 1250 1251 my $pretty_dir_list = join ("\n", @dir_list); 1252 1253 return ($pretty_dir_list); 1254 1255} #-- End of subroutine build_pretty_dir_list 1256 1257#------------------------------------------------------------------------------ 1258# Calculate the target address in hex by adding the instruction to the 1259# instruction address. 1260#------------------------------------------------------------------------------ 1261sub calculate_target_hex_address 1262{ 1263 my $subr_name = get_my_name (); 1264 1265 my ($instruction_address, $instruction_offset) = @_; 1266 1267 my $dec_branch_target; 1268 my $d1; 1269 my $d2; 1270 my $first_char; 1271 my $length_of_string; 1272 my $mask; 1273 my $number_of_fields; 1274 my $raw_hex_branch_target; 1275 my $result; 1276 1277 if ($g_addressing_mode eq "64 bit") 1278 { 1279 $mask = "0xffffffffffffffff"; 1280 $number_of_fields = 16; 1281 } 1282 else 1283 { 1284 gp_message ("abort", $subr_name, "g_addressing_mode = $g_addressing_mode not supported\n"); 1285 } 1286 1287 $length_of_string = length ($instruction_offset); 1288 $first_char = lcfirst (substr ($instruction_offset,0,1)); 1289 $d1 = bigint::hex ($instruction_offset); 1290 $d2 = bigint::hex ($mask); 1291# if ($first_char eq "f") 1292 if (($first_char =~ /[89a-f]/) and ($length_of_string == $number_of_fields)) 1293 { 1294#------------------------------------------------------------------------------ 1295# The offset is negative. Convert to decimal and perform the subtrraction. 1296#------------------------------------------------------------------------------ 1297#------------------------------------------------------------------------------ 1298# XOR the decimal representation and add 1 to the result. 1299#------------------------------------------------------------------------------ 1300 $result = ($d1 ^ $d2) + 1; 1301 $dec_branch_target = bigint::hex ($instruction_address) - $result; 1302 } 1303 else 1304 { 1305 $result = $d1; 1306 $dec_branch_target = bigint::hex ($instruction_address) + $result; 1307 } 1308#------------------------------------------------------------------------------ 1309# Convert to hexadecimal. 1310#------------------------------------------------------------------------------ 1311 $raw_hex_branch_target = sprintf ("%x", $dec_branch_target); 1312 1313 return ($raw_hex_branch_target); 1314 1315} #-- End of subroutine calculate_target_hex_address 1316 1317#------------------------------------------------------------------------------ 1318# Sets the absolute path to all commands in array @cmds. The commands and 1319# their respective paths are stored in hash "g_mapped_cmds". 1320# 1321# If no such mapping is found, a warning is issued, but execution continues. 1322# The warning(s) may help with troubleshooting, should a failure occur later. 1323#------------------------------------------------------------------------------ 1324sub check_and_define_cmds 1325{ 1326 my $subr_name = get_my_name (); 1327 1328 my ($cmds_ref, $search_path_ref) = @_; 1329 1330#------------------------------------------------------------------------------ 1331# Dereference the array addressess first and then store the contents. 1332#------------------------------------------------------------------------------ 1333 my @cmds = @{$cmds_ref}; 1334 my @search_path = @{$search_path_ref}; 1335 1336 my $found_match; 1337 my $target_cmd; 1338 my $failed_cmd; 1339 my $no_of_failed_mappings; 1340 my $failed_cmds; 1341 1342 gp_message ("debug", $subr_name, "\@cmds = @cmds"); 1343 gp_message ("debug", $subr_name, "\@search_path = @search_path"); 1344 1345#------------------------------------------------------------------------------ 1346# Search for the command to be in the search path given. In case no such path 1347# can be found, the entry in $g_mapped_cmds is assigned a special value that 1348# will be checked for in the next block. 1349#------------------------------------------------------------------------------ 1350 for my $cmd (@cmds) 1351 { 1352 $found_match = $FALSE; 1353 for my $path (@search_path) 1354 { 1355 $target_cmd = $path . "/" . $cmd; 1356 if (-x $target_cmd) 1357 { 1358 $found_match = $TRUE; 1359 $g_mapped_cmds{$cmd} = $target_cmd; 1360 last; 1361 } 1362 } 1363 1364 if (not $found_match) 1365 { 1366 $g_mapped_cmds{$cmd} = "road_to_nowhere"; 1367 } 1368 } 1369 1370#------------------------------------------------------------------------------ 1371# Scan the results stored in $g_mapped_cmds and flag errors. 1372#------------------------------------------------------------------------------ 1373 $no_of_failed_mappings = 0; 1374 $failed_cmds = ""; 1375 while ( my ($cmd, $mapped) = each %g_mapped_cmds) 1376 { 1377 if ($mapped eq "road_to_nowhere") 1378 { 1379 my $msg = "cannot find a path for command $cmd - " . 1380 "assume this will still work without a path"; 1381 gp_message ("warning", $subr_name, $msg); 1382 $no_of_failed_mappings++; 1383 $failed_cmds .= $cmd; 1384 $g_mapped_cmds{$cmd} = $cmd; 1385 } 1386 else 1387 { 1388 gp_message ("debug", $subr_name, "path for the $cmd command is $mapped"); 1389 } 1390 } 1391 if ($no_of_failed_mappings != 0) 1392 { 1393 gp_message ("debug", $subr_name, "failed to find a mapping for $failed_cmds"); 1394 gp_message ("debug", $subr_name, "a total of $no_of_failed_mappings mapping failures"); 1395 } 1396 1397 return ($no_of_failed_mappings); 1398 1399} #-- End of subroutine check_and_define_cmds 1400 1401#------------------------------------------------------------------------------ 1402# Look for a branch instruction, or the special endbr32/endbr64 instruction 1403# that is also considered to be a branch target. Note that the latter is x86 1404# specific. 1405#------------------------------------------------------------------------------ 1406sub check_and_proc_dis_branches 1407{ 1408 my $subr_name = get_my_name (); 1409 1410 my ($input_line_ref, $line_no_ref, $branch_target_ref, 1411 $extended_branch_target_ref, $branch_target_no_ref_ref) = @_; 1412 1413 my $input_line = ${ $input_line_ref }; 1414 my $line_no = ${ $line_no_ref }; 1415 my %branch_target = %{ $branch_target_ref }; 1416 my %extended_branch_target = %{ $extended_branch_target_ref }; 1417 my %branch_target_no_ref = %{ $branch_target_no_ref_ref }; 1418 1419 my $found_it = $TRUE; 1420 my $hex_branch_target; 1421 my $instruction_address; 1422 my $instruction_offset; 1423 my $msg; 1424 my $raw_hex_branch_target; 1425 1426 if ( ($input_line =~ /$g_branch_regex/) 1427 or ($input_line =~ /$g_endbr_regex/)) 1428 { 1429 if (defined ($3)) 1430 { 1431 $msg = "found a branch or endbr instruction: " . 1432 "\$1 = $1 \$2 = $2 \$3 = $3"; 1433 } 1434 else 1435 { 1436 $msg = "found a branch or endbr instruction: " . 1437 "\$1 = $1 \$2 = $2"; 1438 } 1439 gp_message ("debugXL", $subr_name, $msg); 1440 1441 if (defined ($1)) 1442 { 1443#------------------------------------------------------------------------------ 1444# Found a qualifying instruction 1445#------------------------------------------------------------------------------ 1446 $instruction_address = $1; 1447 if (defined ($3)) 1448 { 1449#------------------------------------------------------------------------------ 1450# This must be the branch target and needs to be converted and processed. 1451#------------------------------------------------------------------------------ 1452 $instruction_offset = $3; 1453 $raw_hex_branch_target = calculate_target_hex_address ( 1454 $instruction_address, 1455 $instruction_offset); 1456 1457 $hex_branch_target = "0x" . $raw_hex_branch_target; 1458 $branch_target{$hex_branch_target} = 1; 1459 $extended_branch_target{$instruction_address} = $raw_hex_branch_target; 1460 } 1461 if (defined ($2) and (not defined ($3))) 1462 { 1463#------------------------------------------------------------------------------ 1464# Unlike a branch, the endbr32/endbr64 instructions do not have a second field. 1465#------------------------------------------------------------------------------ 1466 my $instruction_name = $2; 1467 if ($instruction_name =~ /$g_endbr_inst_regex/) 1468 { 1469 my $msg = "found endbr: $instruction_name " . 1470 $instruction_address; 1471 gp_message ("debugXL", $subr_name, $msg); 1472 $raw_hex_branch_target = $instruction_address; 1473 1474 $hex_branch_target = "0x" . $raw_hex_branch_target; 1475 $branch_target_no_ref{$instruction_address} = 1; 1476 } 1477 } 1478 } 1479 else 1480 { 1481#------------------------------------------------------------------------------ 1482# TBD: Perhaps this should be an assertion or alike. 1483#------------------------------------------------------------------------------ 1484 $branch_target{"0x0000"} = $FALSE; 1485 gp_message ("debug", $subr_name, "cannot determine branch target"); 1486 } 1487 } 1488 else 1489 { 1490 $found_it = $FALSE; 1491 } 1492 1493 return (\$found_it, \%branch_target, \%extended_branch_target, 1494 \%branch_target_no_ref); 1495 1496} #-- End of subroutine check_and_proc_dis_branches 1497 1498#------------------------------------------------------------------------------ 1499# Check an input line from the disassembly file to include a function call. 1500# If it does, process the line and return the branch target results. 1501#------------------------------------------------------------------------------ 1502sub check_and_proc_dis_func_call 1503{ 1504 my $subr_name = get_my_name (); 1505 1506 my ($input_line_ref, $line_no_ref, $branch_target_ref, 1507 $extended_branch_target_ref) = @_; 1508 1509 my $input_line = ${ $input_line_ref }; 1510 my $line_no = ${ $line_no_ref }; 1511 my %branch_target = %{ $branch_target_ref }; 1512 my %extended_branch_target = %{ $extended_branch_target_ref }; 1513 1514 my $found_it = $TRUE; 1515 my $hex_branch_target; 1516 my $instruction_address; 1517 my $instruction_offset; 1518 my $msg; 1519 my $raw_hex_branch_target; 1520 1521 if ( $input_line =~ /$g_function_call_v2_regex/ ) 1522 { 1523 $msg = "found a function call - line[$line_no] = $input_line"; 1524 gp_message ("debugXL", $subr_name, $msg); 1525 if (not defined ($2)) 1526 { 1527 $msg = "line[$line_no] " . 1528 "an instruction address is expected, but not found"; 1529 gp_message ("assertion", $subr_name, $msg); 1530 } 1531 else 1532 { 1533 $instruction_address = $2; 1534 1535 $msg = "instruction_address = $instruction_address"; 1536 gp_message ("debugXL", $subr_name, $msg); 1537 1538 if (not defined ($4)) 1539 { 1540 $msg = "line[$line_no] " . 1541 "an address offset is expected, but not found"; 1542 gp_message ("assertion", $subr_name, $msg); 1543 } 1544 else 1545 { 1546 $instruction_offset = $4; 1547 if ($instruction_offset =~ /[0-9a-fA-F]+/) 1548 { 1549 $msg = "calculate branch target: " . 1550 "instruction_address = $instruction_address"; 1551 gp_message ("debugXL", $subr_name, $msg); 1552 $msg = "calculate branch target: " . 1553 "instruction_offset = $instruction_offset"; 1554 gp_message ("debugXL", $subr_name, $msg); 1555 1556#------------------------------------------------------------------------------ 1557# The instruction offset needs to be converted and added to the instruction 1558# address. 1559#------------------------------------------------------------------------------ 1560 $raw_hex_branch_target = calculate_target_hex_address ( 1561 $instruction_address, 1562 $instruction_offset); 1563 $hex_branch_target = "0x" . $raw_hex_branch_target; 1564 1565 $msg = "calculated hex_branch_target = " . 1566 $hex_branch_target; 1567 gp_message ("debugXL", $subr_name, $msg); 1568 1569 $branch_target{$hex_branch_target} = 1; 1570 $extended_branch_target{$instruction_address} = $raw_hex_branch_target; 1571 1572 $msg = "set branch_target{$hex_branch_target} to 1"; 1573 gp_message ("debugXL", $subr_name, $msg); 1574 $msg = "added extended_branch_target{$instruction_address}" . 1575 " = $extended_branch_target{$instruction_address}"; 1576 gp_message ("debugXL", $subr_name, $msg); 1577 } 1578 else 1579 { 1580 $msg = "line[$line_no] unknown address format"; 1581 gp_message ("assertion", $subr_name, $msg); 1582 } 1583 } 1584 } 1585 } 1586 else 1587 { 1588 $found_it = $FALSE; 1589 } 1590 1591 return (\$found_it, \%branch_target, \%extended_branch_target); 1592 1593} #-- End of subroutine check_and_proc_dis_func_call 1594 1595#------------------------------------------------------------------------------ 1596# Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool 1597# needed to provide the information. If it can not be found, execution is 1598# terminated. 1599# 1600# We first search foe this tool in the current execution directory. If it 1601# cannot be found there, use $PATH to try to locate it. 1602#------------------------------------------------------------------------------ 1603sub check_availability_tool 1604{ 1605 my $subr_name = get_my_name (); 1606 1607 my ($location_gp_command_ref) = @_; 1608 1609 my $error_code; 1610 my $error_occurred; 1611 my $msg; 1612 my $output_which_gp_display_text; 1613 my $return_value; 1614 my $target_cmd; 1615 1616#------------------------------------------------------------------------------ 1617# Get the path to gp-display-text. 1618#------------------------------------------------------------------------------ 1619 my ($error_occurred_ref, $return_value_ref) = find_path_to_gp_display_text ( 1620 $location_gp_command_ref 1621 ); 1622 $error_occurred = ${ $error_occurred_ref}; 1623 $return_value = ${ $return_value_ref}; 1624 1625 $msg = "error_occurred = $error_occurred return_value = $return_value"; 1626 gp_message ("debugXL", $subr_name, $msg); 1627 1628 if (not $error_occurred) 1629#------------------------------------------------------------------------------ 1630# All is well and gp-display-text has been located. 1631#------------------------------------------------------------------------------ 1632 { 1633 $g_path_to_tools = $return_value; 1634 1635 $msg = "located $GP_DISPLAY_TEXT in execution directory"; 1636 gp_message ("debug", $subr_name, $msg); 1637 $msg = "g_path_to_tools = $g_path_to_tools"; 1638 gp_message ("debug", $subr_name, $msg); 1639 } 1640 else 1641#------------------------------------------------------------------------------ 1642# Something went wrong, but perhaps we can still continue. Try to find 1643# $GP_DISPLAY_TEXT through the search path. 1644#------------------------------------------------------------------------------ 1645 { 1646 $msg = "error accessing $GP_DISPLAY_TEXT: $return_value - " . 1647 "run time behaviour may be undefined"; 1648 gp_message ("warning", $subr_name, $msg); 1649 1650#------------------------------------------------------------------------------ 1651# Check if we can find $GP_DISPLAY_TEXT in the search path. 1652#------------------------------------------------------------------------------ 1653 $msg = "check for $GP_DISPLAY_TEXT in search path"; 1654 gp_message ("debug", $subr_name, $msg); 1655 1656 $target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1"; 1657 1658 ($error_code, $output_which_gp_display_text) = 1659 execute_system_cmd ($target_cmd); 1660 1661 if ($error_code == 0) 1662 { 1663 my ($gp_file_name, $gp_path, $suffix_not_used) = 1664 fileparse ($output_which_gp_display_text); 1665 $g_path_to_tools = $gp_path; 1666 1667 $msg = "using $GP_DISPLAY_TEXT in $g_path_to_tools instead"; 1668 gp_message ("warning", $subr_name, $msg); 1669 1670 $msg = "the $GP_DISPLAY_TEXT tool is in the search path"; 1671 gp_message ("debug", $subr_name, $msg); 1672 $msg = "g_path_to_tools = $g_path_to_tools"; 1673 gp_message ("debug", $subr_name, $msg); 1674 } 1675 else 1676 { 1677 $msg = "failure to find $GP_DISPLAY_TEXT in the search path"; 1678 gp_message ("debug", $subr_name, $msg); 1679 1680 $msg = "fatal error executing command $target_cmd"; 1681 gp_message ("abort", $subr_name, $msg); 1682 } 1683 } 1684 1685 return (\$g_path_to_tools); 1686 1687} #-- End of subroutine check_availability_tool 1688 1689#------------------------------------------------------------------------------ 1690# This function determines whether load objects are in ELF format. 1691# 1692# Compared to the original code, any input value other than 2 or 3 is rejected 1693# upfront. This not only reduces the nesting level, but also eliminates a 1694# possible bug. 1695# 1696# Also, by isolating the tests for the input files, another nesting level could 1697# be eliminated, further simplifying this still too complex code. 1698#------------------------------------------------------------------------------ 1699sub check_loadobjects_are_elf 1700{ 1701 my $subr_name = get_my_name (); 1702 1703 my ($selected_archive) = @_; 1704 1705 my $hostname_current = $local_system_config{"hostname_current"}; 1706 my $arch = $local_system_config{"processor"}; 1707 my $arch_uname_s = $local_system_config{"kernel_name"}; 1708 1709 my $extracted_information; 1710 1711 my $elf_magic_number; 1712 1713 my $executable_name; 1714 my $va_executable_in_hex; 1715 1716 my $arch_exp; 1717 my $hostname_exp; 1718 my $os_exp; 1719 my $os_exp_full; 1720 1721 my $archives_file; 1722 my $rc_b; 1723 my $file; 1724 my $line; 1725 my $name; 1726 my $name_path; 1727 my $foffset; 1728 my $vaddr; 1729 my $modes; 1730 1731 my $path_to_map_file; 1732 my $path_to_log_file; 1733 1734#------------------------------------------------------------------------------ 1735# TBD: Parameterize and should be the first experiment directory from the list. 1736#------------------------------------------------------------------------------ 1737 $path_to_log_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; 1738 $path_to_log_file .= $selected_archive; 1739 $path_to_log_file .= "/log.xml"; 1740 1741 gp_message ("debug", $subr_name, "hostname_current = $hostname_current"); 1742 gp_message ("debug", $subr_name, "arch = $arch"); 1743 gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s"); 1744 1745#------------------------------------------------------------------------------ 1746# TBD 1747# 1748# This check can probably be removed since the presence of the log.xml file is 1749# checked for in an earlier phase. 1750#------------------------------------------------------------------------------ 1751 open (LOG_XML, "<", $path_to_log_file) 1752 or die ("$subr_name - unable to open file $path_to_log_file for reading: '$!'"); 1753 gp_message ("debug", $subr_name, "opened file $path_to_log_file for reading"); 1754 1755 while (<LOG_XML>) 1756 { 1757 $line = $_; 1758 chomp ($line); 1759 gp_message ("debug", $subr_name, "read line: $line"); 1760#------------------------------------------------------------------------------ 1761# Search for the first line starting with "<system". Bail out if found and 1762# parsed. These are two examples: 1763# <system hostname="ruud-vm" arch="x86_64" os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514"> 1764# <system hostname="sca-m88-092-pd0" arch="sun4v" os="SunOS 5.11" pagesz="8192" npages="602963968"> 1765#------------------------------------------------------------------------------ 1766 if ($line =~ /^\s*<system\s+/) 1767 { 1768 gp_message ("debug", $subr_name, "selected the following line from the log.xml file:"); 1769 gp_message ("debug", $subr_name, "$line"); 1770 if ($line =~ /.*\s+hostname="([^"]+)/) 1771 { 1772 $hostname_exp = $1; 1773 gp_message ("debug", $subr_name, "extracted hostname_exp = $hostname_exp"); 1774 } 1775 if ($line =~ /.*\s+arch="([^"]+)/) 1776 { 1777 $arch_exp = $1; 1778 gp_message ("debug", $subr_name, "extracted arch_exp = $arch_exp"); 1779 } 1780 if ($line =~ /.*\s+os="([^"]+)/) 1781 { 1782 $os_exp_full = $1; 1783#------------------------------------------------------------------------------ 1784# Capture the first word only. 1785#------------------------------------------------------------------------------ 1786 if ($os_exp_full =~ /([^\s]+)/) 1787 { 1788 $os_exp = $1; 1789 } 1790 gp_message ("debug", $subr_name, "extracted os_exp = $os_exp"); 1791 } 1792 last; 1793 } 1794 } #-- End of while loop 1795 1796 close (LOG_XML); 1797 1798#------------------------------------------------------------------------------ 1799# If the current system is identical to the system used in the experiment, 1800# we can return early. Otherwise we need to dig deeper. 1801# 1802# TBD: How about the other experiment directories?! This needs to be fixed. 1803#------------------------------------------------------------------------------ 1804 1805 gp_message ("debug", $subr_name, "completed while loop"); 1806 gp_message ("debug", $subr_name, "hostname_exp = $hostname_exp"); 1807 gp_message ("debug", $subr_name, "arch_exp = $arch_exp"); 1808 gp_message ("debug", $subr_name, "os_exp = $os_exp"); 1809 1810#TBD: THIS DOES NOT CHECK IF ELF IS FOUND! 1811 1812 if (($hostname_current eq $hostname_exp) and 1813 ($arch eq $arch_exp) and 1814 ($arch_uname_s eq $os_exp)) 1815 { 1816 gp_message ("debug", $subr_name, "early return: the hostname, architecture and OS match the current system"); 1817 gp_message ("debug", $subr_name, "FAKE THIS IS NOT THE CASE AND CONTINUE"); 1818# FAKE return ($TRUE); 1819 } 1820 1821 if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"}) 1822 { 1823 gp_message ("debug", $subr_name, "selected_archive = $selected_archive"); 1824 for my $i (sort keys %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}}) 1825 { 1826 gp_message ("debug", $subr_name, "stored loadobject $i $g_exp_dir_meta_data{$selected_archive}{'archive_files'}{$i}"); 1827 } 1828 } 1829 1830#------------------------------------------------------------------------------ 1831# Check if the selected experiment directory has archived files in ELF format. 1832# If not, use the information in map.xml to get the name of the executable 1833# and the virtual address. 1834#------------------------------------------------------------------------------ 1835 1836 if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"}) 1837 { 1838 gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are in ELF format"); 1839 gp_message ("debug", $subr_name, "IGNORE THIS AND USE MAP.XML"); 1840## return ($TRUE); 1841 } 1842 1843 gp_message ("debug", $subr_name, "the files in directory $selected_archive/archives are not in ELF format"); 1844 1845 $path_to_map_file = $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; 1846 $path_to_map_file .= $selected_archive; 1847 $path_to_map_file .= "/map.xml"; 1848 1849 open (MAP_XML, "<", $path_to_map_file) 1850 or die ($subr_name, "unable to open file $path_to_map_file for reading: $!"); 1851 gp_message ("debug", $subr_name, "opened file $path_to_map_file for reading"); 1852 1853#------------------------------------------------------------------------------ 1854# Scan the map.xml file. We need to find the name of the executable with the 1855# mode set to 0x005. For this entry we have to capture the virtual address. 1856#------------------------------------------------------------------------------ 1857 $extracted_information = $FALSE; 1858 while (<MAP_XML>) 1859 { 1860 $line = $_; 1861 chomp ($line); 1862 gp_message ("debug", $subr_name, "MAP_XML read line = $line"); 1863## if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+ .*modes="0x([0-9]+)"\s.*name="(.*)".*>$/) 1864 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="(.*)".*>$/) 1865 { 1866 gp_message ("debug", $subr_name, "target line = $line"); 1867 $vaddr = $1; 1868 $foffset = $2; 1869 $modes = $3; 1870 $name_path = $4; 1871 $name = get_basename ($name_path); 1872 gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes"); 1873 gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name"); 1874# $error_extracting_information = $TRUE; 1875 $executable_name = $name; 1876 my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); 1877 my $hex_VA = sprintf ("0x%016x", $result_VA); 1878 $va_executable_in_hex = $hex_VA; 1879 gp_message ("debug", $subr_name, "set executable_name = $executable_name"); 1880 gp_message ("debug", $subr_name, "set va_executable_in_hex = $va_executable_in_hex"); 1881 gp_message ("debug", $subr_name, "result_VA = $result_VA"); 1882 gp_message ("debug", $subr_name, "hex_VA = $hex_VA"); 1883 if ($modes eq "005") 1884 { 1885 $extracted_information = $TRUE; 1886 last; 1887 } 1888 } 1889 } 1890 if (not $extracted_information) 1891 { 1892 my $msg = "cannot find the necessary information in the $path_to_map_file file"; 1893 gp_message ("assertion", $subr_name, $msg); 1894 } 1895 1896## $executable_name = $ARCHIVES_MAP_NAME; 1897## $va_executable_in_hex = $ARCHIVES_MAP_VADDR; 1898 1899 return ($executable_name, $va_executable_in_hex); 1900 1901} #-- End of subroutine check_loadobjects_are_elf 1902 1903#------------------------------------------------------------------------------ 1904# Compare the current metric values against the maximum values. Mark the line 1905# if a value is within the percentage defined by $hp_value. 1906#------------------------------------------------------------------------------ 1907sub check_metric_values 1908{ 1909 my $subr_name = get_my_name (); 1910 1911 my ($metric_values, $max_metric_values_ref) = @_; 1912 1913 my @max_metric_values = @{ $max_metric_values_ref }; 1914 1915 my @current_metrics = (); 1916 my $colour_coded_line; 1917 my $current_value; 1918 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; 1919 my $max_value; 1920 my $relative_distance; 1921 1922 @current_metrics = split (" ", $metric_values); 1923 $colour_coded_line = $FALSE; 1924 for my $metric (0 .. $#current_metrics) 1925 { 1926 $current_value = $current_metrics[$metric]; 1927 if (exists ($max_metric_values[$metric])) 1928 { 1929 $max_value = $max_metric_values[$metric]; 1930 gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); 1931 if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) ) 1932 { 1933# TBD: abs needed? 1934 gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); 1935 $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value ); 1936 gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance"); 1937 if ($relative_distance >= $hp_value/100.0) 1938 { 1939 gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance"); 1940 $colour_coded_line = $TRUE; 1941 last; 1942 } 1943 } 1944 } 1945 } #-- End of loop over metrics 1946 1947 return (\$colour_coded_line); 1948 1949} #-- End of subroutine check_metric_values 1950 1951#------------------------------------------------------------------------------ 1952# Check if the system is supported. 1953#------------------------------------------------------------------------------ 1954sub check_support_for_processor 1955{ 1956 my $subr_name = get_my_name (); 1957 1958 my ($machine_ref) = @_; 1959 1960 my $machine = ${ $machine_ref }; 1961 my $is_supported; 1962 1963 if ($machine eq "x86_64") 1964 { 1965 $is_supported = $TRUE; 1966 } 1967 else 1968 { 1969 $is_supported = $FALSE; 1970 } 1971 1972 return (\$is_supported); 1973 1974} #-- End of subroutine check_support_for_processor 1975 1976#------------------------------------------------------------------------------ 1977# Check if the value for the user option given is valid. 1978# 1979# In case the value is valid, the g_user_settings table is updated. 1980# Otherwise an error message is printed. 1981# 1982# The return value is TRUE/FALSE. 1983#------------------------------------------------------------------------------ 1984sub check_user_option 1985{ 1986 my $subr_name = get_my_name (); 1987 1988 my ($internal_option_name, $value) = @_; 1989 1990 my $message; 1991 my $return_value; 1992 1993 my $option = $g_user_settings{$internal_option_name}{"option"}; 1994 my $data_type = $g_user_settings{$internal_option_name}{"data_type"}; 1995 my $no_of_arguments = $g_user_settings{$internal_option_name}{"no_of_arguments"}; 1996 1997 if (($no_of_arguments >= 1) and 1998 ((not defined ($value)) or (length ($value) == 0))) 1999 { 2000#------------------------------------------------------------------------------ 2001# If there was no value given, but it is required, flag an error. 2002# There could also be a value, but it might be the empty string. 2003# 2004# Note that that there are currently no options with multiple values. Should 2005# these be introduced, the current check may need to be refined. 2006#------------------------------------------------------------------------------ 2007 2008 $message = "the $option option requires a value"; 2009 push (@g_user_input_errors, $message); 2010 $return_value = $FALSE; 2011 } 2012 elsif ($no_of_arguments >= 1) 2013 { 2014#------------------------------------------------------------------------------ 2015# There is an input value. Check if it is valid and if so, store it. 2016# 2017# Note that we allow the options to be case insensitive. 2018#------------------------------------------------------------------------------ 2019 my $valid = verify_if_input_is_valid ($value, $data_type); 2020 2021 if ($valid) 2022 { 2023 if (($data_type eq "onoff") or ($data_type eq "size")) 2024 { 2025 $g_user_settings{$internal_option_name}{"current_value"} = lc ($value); 2026 } 2027 else 2028 { 2029 $g_user_settings{$internal_option_name}{"current_value"} = $value; 2030 } 2031 $g_user_settings{$internal_option_name}{"defined"} = $TRUE; 2032 $return_value = $TRUE; 2033 } 2034 else 2035 { 2036 $message = "incorrect value for $option option: $value"; 2037 push (@g_user_input_errors, $message); 2038 2039 $return_value = $FALSE; 2040 } 2041 } 2042 2043 return ($return_value); 2044 2045} #-- End of subroutine check_user_option 2046 2047#------------------------------------------------------------------------------- 2048# This subroutine performs multiple checks on the experiment directories. One 2049# or more failures are fatal. 2050#------------------------------------------------------------------------------- 2051sub check_validity_exp_dirs 2052{ 2053 my $subr_name = get_my_name (); 2054 2055 my ($exp_dir_list_ref) = @_; 2056 2057 my @exp_dir_list = @{ $exp_dir_list_ref }; 2058 2059 my %elf_rats = (); 2060 2061 my $dir_not_found = $FALSE; 2062 my $invalid_dir = $FALSE; 2063 my $dir_check_errors = $FALSE; 2064 my $missing_dirs = 0; 2065 my $invalid_dirs = 0; 2066 2067 my $archive_dir_not_empty; 2068 my $elf_magic_number; 2069 my $archives_file; 2070 my $archives_dir; 2071 my $first_line; 2072 my $count_exp_dir_not_elf; 2073 2074 my $first_time; 2075 my $filename; 2076 2077 my $comment; 2078 2079 my $selected_archive_has_elf_format; 2080 2081 my $selected_archive; 2082 my $archive_dir_selected; 2083 my $no_of_files_in_selected_archive; 2084 2085#------------------------------------------------------------------------------- 2086# Check if the experiment directories exist and are valid. 2087#------------------------------------------------------------------------------- 2088 for my $exp_dir (@exp_dir_list) 2089 { 2090 if (not -d $exp_dir) 2091 { 2092 $dir_not_found = $TRUE; 2093 $missing_dirs++; 2094 gp_message ("error", $subr_name, "directory $exp_dir not found"); 2095 $dir_check_errors = $TRUE; 2096 } 2097 else 2098 { 2099#------------------------------------------------------------------------------- 2100# Files log.xml and map.xml have to be there. 2101#------------------------------------------------------------------------------- 2102 gp_message ("debug", $subr_name, "directory $exp_dir found"); 2103 if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml")) 2104 { 2105 gp_message ("debug", $subr_name, "directory $exp_dir appears to be a valid experiment directory"); 2106 } 2107 else 2108 { 2109 $invalid_dir = $TRUE; 2110 $invalid_dirs++; 2111 gp_message ("debug", $subr_name, "file ".$exp_dir."/log.xml and/or ".$exp_dir."/map.xml missing"); 2112 gp_message ("error" , $subr_name, "directory $exp_dir does not appear to be a valid experiment directory"); 2113 $dir_check_errors = $TRUE; 2114 } 2115 } 2116 } 2117 if ($dir_not_found) 2118 { 2119 gp_message ("error", $subr_name, "a total of $missing_dirs directories not found"); 2120 } 2121 if ($invalid_dir) 2122 { 2123 gp_message ("abort", $subr_name, "a total of $invalid_dirs directories are not valid"); 2124 } 2125 2126#------------------------------------------------------------------------------- 2127# Initialize ELF status to FALSE. 2128#------------------------------------------------------------------------------- 2129## for my $exp_dir (@exp_dir_list) 2130 for my $exp_dir (keys %g_exp_dir_meta_data) 2131 { 2132 $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE; 2133 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; 2134 } 2135#------------------------------------------------------------------------------- 2136# Check if the load objects are in ELF format. 2137#------------------------------------------------------------------------------- 2138 for my $exp_dir (keys %g_exp_dir_meta_data) 2139 { 2140 $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives"; 2141 $archive_dir_not_empty = $FALSE; 2142 $first_time = $TRUE; 2143 $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE; 2144 $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0; 2145 2146 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'}"); 2147 gp_message ("debug", $subr_name, "checking $archives_dir"); 2148 2149 while (glob ("$archives_dir/*")) 2150 { 2151 $filename = get_basename ($_); 2152 gp_message ("debug", $subr_name, "processing file: $filename"); 2153 2154 $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE; 2155 $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++; 2156 2157 $archive_dir_not_empty = $TRUE; 2158#------------------------------------------------------------------------------- 2159# Replaces the ELF_RATS part in elf_phdr. 2160# 2161# Challenge: splittable_mrg.c_I0txnOW_Wn5 2162# 2163# TBD: Store this for each relevant experiment directory. 2164#------------------------------------------------------------------------------- 2165 my $last_dot = rindex ($filename,"."); 2166 my $underscore_before_dot = $TRUE; 2167 my $first_underscore = -1; 2168 gp_message ("debugXL", $subr_name, "last_dot = $last_dot"); 2169 while ($underscore_before_dot) 2170 { 2171 $first_underscore = index ($filename, "_", $first_underscore+1); 2172 if ($last_dot < $first_underscore) 2173 { 2174 $underscore_before_dot = $FALSE; 2175 } 2176 } 2177 my $original_name = substr ($filename, 0, $first_underscore); 2178 gp_message ("debug", $subr_name, "stripped archive name: $original_name"); 2179 if (not exists ($elf_rats{$original_name})) 2180 { 2181 $elf_rats{$original_name} = [$filename, $exp_dir]; 2182 } 2183#------------------------------------------------------------------------------- 2184# We only need to detect the presence of an object once. 2185#------------------------------------------------------------------------------- 2186 if ($first_time) 2187 { 2188 $first_time = $FALSE; 2189 $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE; 2190 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'}"); 2191 } 2192 } 2193 } #-- End of loop over experiment directories 2194 2195 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2196 { 2197 my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; 2198 gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($empty ? "empty" : "not empty")); 2199 } 2200 2201#------------------------------------------------------------------------------ 2202# Verify that all relevant files in the archive directories are in ELF format. 2203#------------------------------------------------------------------------------ 2204 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2205 { 2206 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; 2207 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2208 { 2209 $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives"; 2210 gp_message ("debug", $subr_name, "exp_dir = $exp_dir archives_dir = $archives_dir"); 2211#------------------------------------------------------------------------------ 2212# Check if any of the loadobjects is of type ELF. Bail out on the first one 2213# found. The assumption is that all other loadobjects must be of type ELF too 2214# then. 2215#------------------------------------------------------------------------------ 2216 for my $aname (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) 2217 { 2218 $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"} . $exp_dir . "/archives/" . $aname; 2219 open (ARCF,"<", $filename) 2220 or die ("unable to open file $filename for reading - '$!'"); 2221 2222 $first_line = <ARCF>; 2223 close (ARCF); 2224 2225#------------------------------------------------------------------------------ 2226# The first 4 hex fields in the header of an ELF file are: 7F 45 4c 46 (7FELF). 2227# 2228# See also https://en.wikipedia.org/wiki/Executable_and_Linkable_Format 2229#------------------------------------------------------------------------------ 2230# if ($first_line =~ /^\177ELF.*/) 2231 2232 $elf_magic_number = unpack ('H8', $first_line); 2233# gp_message ("debug", $subr_name, "elf_magic_number = $elf_magic_number"); 2234 if ($elf_magic_number eq "7f454c46") 2235 { 2236 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $TRUE; 2237 $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE; 2238 last; 2239 } 2240 } 2241 } 2242 } 2243 2244 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2245 { 2246 $comment = "the loadobjects in the archive in $exp_dir are "; 2247 $comment .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? "in " : "not in "; 2248 $comment .= "ELF format"; 2249 gp_message ("debug", $subr_name, $comment); 2250 } 2251 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2252 { 2253 if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2254 { 2255 gp_message ("debug", $subr_name, "there are no archived files in $exp_dir"); 2256 } 2257 } 2258 2259#------------------------------------------------------------------------------ 2260# If there are archived files and they are not in ELF format, a debug is 2261# issued. 2262# 2263# TBD: Bail out? 2264#------------------------------------------------------------------------------ 2265 $count_exp_dir_not_elf = 0; 2266 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2267 { 2268 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) 2269 { 2270 $count_exp_dir_not_elf++; 2271 } 2272 } 2273 if ($count_exp_dir_not_elf != 0) 2274 { 2275 gp_message ("debug", $subr_name, "there are $count_exp_dir_not_elf experiments with non-ELF load objects"); 2276 } 2277 2278#------------------------------------------------------------------------------ 2279# Select the experiment directory that is used for the files in the archive. 2280# By default, a directory with archived files is used, but in case this does 2281# not exist, a directory without archived files is selected. Obviously this 2282# needs to be dealt with later on. 2283#------------------------------------------------------------------------------ 2284 2285#------------------------------------------------------------------------------ 2286# Try the experiments with archived files first. 2287#------------------------------------------------------------------------------ 2288 $archive_dir_not_empty = $FALSE; 2289 $archive_dir_selected = $FALSE; 2290## for my $exp_dir (sort @exp_dir_list) 2291 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2292 { 2293 gp_message ("debugXL", $subr_name, "exp_dir = $exp_dir"); 2294 gp_message ("debugXL", $subr_name, "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"); 2295 2296 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2297 { 2298 $selected_archive = $exp_dir; 2299 $archive_dir_not_empty = $TRUE; 2300 $archive_dir_selected = $TRUE; 2301 $selected_archive_has_elf_format = ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? $TRUE : $FALSE; 2302 last; 2303 } 2304 } 2305 if (not $archive_dir_selected) 2306#------------------------------------------------------------------------------ 2307# None are found and pick the first one without archived files. 2308#------------------------------------------------------------------------------ 2309 { 2310 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2311 { 2312 if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2313 { 2314 $selected_archive = $exp_dir; 2315 $archive_dir_not_empty = $FALSE; 2316 $archive_dir_selected = $TRUE; 2317 $selected_archive_has_elf_format = $FALSE; 2318 last; 2319 } 2320 } 2321 } 2322 gp_message ("debug", $subr_name, "experiment $selected_archive has been selected for archive analysis"); 2323 gp_message ("debug", $subr_name, "this archive is ". (($archive_dir_not_empty) ? "not empty" : "empty")); 2324 gp_message ("debug", $subr_name, "this archive is ". (($selected_archive_has_elf_format) ? "in" : "not in")." ELF format"); 2325#------------------------------------------------------------------------------ 2326# Get the size of the hash that contains the archived files. 2327#------------------------------------------------------------------------------ 2328## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES); 2329 2330 $no_of_files_in_selected_archive = $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"}; 2331 gp_message ("debug", $subr_name, "number of files in archive $selected_archive is $no_of_files_in_selected_archive"); 2332 2333 2334 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2335 { 2336 my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; 2337 gp_message ("debug", $subr_name, "archive directory $exp_dir/archives is ".($is_empty ? "empty" : "not empty")); 2338 } 2339 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2340 { 2341 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2342 { 2343 for my $object (sort keys %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) 2344 { 2345 gp_message ("debug", $subr_name, "$exp_dir $object $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}"); 2346 } 2347 } 2348 } 2349 2350 return ($dir_check_errors, $archive_dir_not_empty, $selected_archive, \%elf_rats); 2351 2352} #-- End of subroutine check_validity_exp_dirs 2353 2354#------------------------------------------------------------------------------ 2355# Color the string and optionally mark it boldface. 2356# 2357# For supported colors, see: 2358# https://www.w3schools.com/colors/colors_names.asp 2359#------------------------------------------------------------------------------ 2360sub color_string 2361{ 2362 my $subr_name = get_my_name (); 2363 2364 my ($input_string, $boldface, $color) = @_; 2365 2366 my $colored_string; 2367 2368 $colored_string = "<font color='" . $color . "'>"; 2369 2370 if ($boldface) 2371 { 2372 $colored_string .= "<b>"; 2373 } 2374 2375 $colored_string .= $input_string; 2376 2377 if ($boldface) 2378 { 2379 $colored_string .= "</b>"; 2380 } 2381 $colored_string .= "</font>"; 2382 2383 return ($colored_string); 2384 2385} #-- End of subroutine color_string 2386 2387#------------------------------------------------------------------------------ 2388# Generate the array with the info on the experiment(s). 2389#------------------------------------------------------------------------------ 2390sub create_exp_info 2391{ 2392 my $subr_name = get_my_name (); 2393 2394 my ($experiment_dir_list_ref, $experiment_data_ref) = @_; 2395 2396 my @experiment_dir_list = @{ $experiment_dir_list_ref }; 2397 my @experiment_data = @{ $experiment_data_ref }; 2398 2399 my @experiment_stats_html = (); 2400 my $experiment_stats_line; 2401 my $plural; 2402 2403 $plural = ($#experiment_dir_list > 0) ? "s:" : ":"; 2404 2405 $experiment_stats_line = "<h3>\n"; 2406 $experiment_stats_line .= "Full pathnames to the input experiment" . $plural . "\n"; 2407 $experiment_stats_line .= "</h3>\n"; 2408 $experiment_stats_line .= "<pre>\n"; 2409 2410 for my $i (0 .. $#experiment_dir_list) 2411 { 2412 $experiment_stats_line .= $experiment_dir_list[$i] . " (" . $experiment_data[$i]{"start_date"} . ")\n"; 2413 } 2414 $experiment_stats_line .= "</pre>\n"; 2415 2416 push (@experiment_stats_html, $experiment_stats_line); 2417 2418 gp_message ("debugXL", $subr_name, "experiment_stats_line = $experiment_stats_line --"); 2419 2420 return (\@experiment_stats_html); 2421 2422} #-- End of subroutine create_exp_info 2423 2424#------------------------------------------------------------------------------ 2425# Trivial function to generate a tag. This has been made a function to ensure 2426# consistency creating tags and also make it easier to change them. 2427#------------------------------------------------------------------------------ 2428sub create_function_tag 2429{ 2430 my $subr_name = get_my_name (); 2431 2432 my ($tag_id) = @_; 2433 2434 my $function_tag = "function_tag_" . $tag_id; 2435 2436 return ($function_tag); 2437 2438} #-- End of subroutine create_function_tag 2439 2440#------------------------------------------------------------------------------ 2441# Generate and return a string with the credits. Note that this also ends 2442# the HTML formatting controls. 2443#------------------------------------------------------------------------------ 2444sub create_html_credits 2445{ 2446 my $subr_name = get_my_name (); 2447 2448 my $msg; 2449 my $the_date; 2450 2451 my @months = qw (January February March April May June July August September October November December); 2452 2453 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime (); 2454 2455 $year += 1900; 2456 2457 $the_date = $months[$mon] . " " . $mday . ", " . $year; 2458 2459 $msg = "<i>\n"; 2460 $msg .= "Output generated by the $driver_cmd command "; 2461 $msg .= "on $the_date "; 2462 $msg .= "(GNU binutils version " . $binutils_version . ")"; 2463 $msg .= "\n"; 2464 $msg .= "</i>"; 2465 2466 gp_message ("debug", $subr_name, "the date = $the_date"); 2467 2468 return (\$msg); 2469 2470} #-- End of subroutine create_html_credits 2471 2472#------------------------------------------------------------------------------ 2473# Generate a string that contains all the necessary HTML header information, 2474# plus a title. 2475# 2476# See also https://www.w3schools.com for the details on the features used. 2477#------------------------------------------------------------------------------ 2478sub create_html_header 2479{ 2480 my $subr_name = get_my_name (); 2481 2482 my ($title_ref) = @_; 2483 2484 my $title = ${ $title_ref }; 2485 2486 my $LANG = $g_locale_settings{"LANG"}; 2487 my $background_color = $g_html_color_scheme{"background_color_page"}; 2488 2489 my $html_header; 2490 2491 $html_header = "<!DOCTYPE html public \"-//w3c//dtd html 3.2//en\">\n"; 2492 $html_header .= "<html lang=\"$LANG\">\n"; 2493 $html_header .= "<head>\n"; 2494 $html_header .= "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n"; 2495 $html_header .= "<title>" . $title . "</title>\n"; 2496 $html_header .= "</head>\n"; 2497 $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n"; 2498 $html_header .= "<style>\n"; 2499 $html_header .= "div.left {\n"; 2500 $html_header .= "text-align: left;\n"; 2501 $html_header .= "}\n"; 2502 $html_header .= "div.right {\n"; 2503 $html_header .= "text-align: right;\n"; 2504 $html_header .= "}\n"; 2505 $html_header .= "div.center {\n"; 2506 $html_header .= "text-align: center;\n"; 2507 $html_header .= "}\n"; 2508 $html_header .= "div.justify {\n"; 2509 $html_header .= "text-align: justify;\n"; 2510 $html_header .= "}\n"; 2511 $html_header .= "</style>"; 2512 2513 return (\$html_header); 2514 2515} #-- End of subroutine create_html_header 2516 2517#------------------------------------------------------------------------------ 2518# Create an HTML page with the warnings. If there are no warnings, include 2519# line to this extent. The alternative is to supporess the entire page, but 2520# that breaks the consistency in the output. 2521#------------------------------------------------------------------------------ 2522sub create_html_warnings_page 2523{ 2524 my $subr_name = get_my_name (); 2525 2526 my ($outputdir_ref) = @_; 2527 2528 my $outputdir = ${ $outputdir_ref }; 2529 2530 my $file_title; 2531 my $html_acknowledgement; 2532 my $html_end; 2533 my $html_header; 2534 my $html_home_left; 2535 my $html_home_right; 2536 my $html_title_header; 2537 my $msg_no_warnings = "There are no warning messages issued."; 2538 my $page_title; 2539 my $position_text; 2540 my $size_text; 2541 2542 my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html"; 2543 2544 gp_message ("debug", $subr_name, "outfile = $outfile"); 2545 2546 open (WARNINGS_OUT, ">", $outfile) 2547 or die ("unable to open $outfile for writing - '$!'"); 2548 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 2549 2550 gp_message ("debug", $subr_name, "building warning file $outfile"); 2551 2552#------------------------------------------------------------------------------ 2553# Get the number of warnings and in debug mode, print the list. 2554#------------------------------------------------------------------------------ 2555 my $number_of_warnings = scalar (@g_warning_messages); 2556 gp_message ("debug", $subr_name, "number_of_warnings = $number_of_warnings"); 2557 2558 if ($number_of_warnings > 0) 2559 { 2560 for my $i (0 .. $#g_warning_messages) 2561 { 2562 print "$g_warning_messages[$i]\n"; 2563 my $msg = "g_warning_messages[$i] = $g_warning_messages[$i]"; 2564 gp_message ("debug", $subr_name, $msg); 2565 } 2566 } 2567 2568#------------------------------------------------------------------------------ 2569# Generate some of the structures used in the HTML output. 2570#------------------------------------------------------------------------------ 2571 $file_title = "Warning messages"; 2572 $html_header = ${ create_html_header (\$file_title) }; 2573 $html_home_right = ${ generate_home_link ("right") }; 2574 2575 $page_title = "Warning Messages"; 2576 $size_text = "h2"; 2577 $position_text = "center"; 2578 $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 2579 2580#------------------------------------------------------------------------------- 2581# Get the acknowledgement, return to main link, and final html statements. 2582#------------------------------------------------------------------------------- 2583 $html_home_left = ${ generate_home_link ("left") }; 2584 $html_acknowledgement = ${ create_html_credits () }; 2585 $html_end = ${ terminate_html_document () }; 2586 2587#------------------------------------------------------------------------------- 2588# Generate the HTML file. 2589#------------------------------------------------------------------------------- 2590 print WARNINGS_OUT $html_header; 2591 print WARNINGS_OUT $html_home_right; 2592 print WARNINGS_OUT $html_title_header; 2593 2594 if ($number_of_warnings > 0) 2595 { 2596 print WARNINGS_OUT "<pre>\n"; 2597 print WARNINGS_OUT "$_\n" for @g_warning_messages; 2598 print WARNINGS_OUT "</pre>\n"; 2599 } 2600 else 2601 { 2602 print WARNINGS_OUT $msg_no_warnings; 2603 } 2604 2605 print WARNINGS_OUT $html_home_left; 2606 print WARNINGS_OUT "<br>\n"; 2607 print WARNINGS_OUT $html_acknowledgement; 2608 print WARNINGS_OUT $html_end; 2609 2610 close (WARNINGS_OUT); 2611 2612 return (\$number_of_warnings); 2613 2614} #-- End of subroutine create_html_warnings_page 2615 2616#------------------------------------------------------------------------------- 2617# Create a complete table. 2618#------------------------------------------------------------------------------- 2619sub create_table 2620{ 2621 my $subr_name = get_my_name (); 2622 2623 my ($experiment_data_ref, $table_definition_ref) = @_; 2624 2625 my @experiment_data = @{ $experiment_data_ref }; 2626 my @table_definition = @{ $table_definition_ref }; 2627 2628 my @html_exp_table_data = (); 2629 my $html_header_line; 2630 my $html_table_line; 2631 my $html_end_table; 2632 2633 $html_header_line = ${ create_table_header_exp (\@experiment_data) }; 2634 2635 push (@html_exp_table_data, $html_header_line); 2636 2637 for my $i (sort keys @table_definition) 2638 { 2639 $html_table_line = ${ create_table_entry_exp (\$table_definition[$i]{"name"}, 2640 \$table_definition[$i]{"key"}, \@experiment_data) }; 2641 push (@html_exp_table_data, $html_table_line); 2642 2643 my $msg = "i = $i html_table_line = $html_table_line"; 2644 gp_message ("debugXL", $subr_name, $msg); 2645 } 2646 2647 $html_end_table = "</table>\n"; 2648 push (@html_exp_table_data, $html_end_table); 2649 2650 return (\@html_exp_table_data); 2651 2652} #-- End of subroutine create_table 2653 2654#------------------------------------------------------------------------------- 2655# Create one row for the table with experiment info. 2656#------------------------------------------------------------------------------- 2657sub create_table_entry_exp 2658{ 2659 my $subr_name = get_my_name (); 2660 2661 my ($entry_name_ref, $key_ref, $experiment_data_ref) = @_; 2662 2663 my $entry_name = ${ $entry_name_ref }; 2664 my $key = ${ $key_ref }; 2665 my @experiment_data = @{ $experiment_data_ref }; 2666 2667 gp_message ("debugXL", $subr_name, "entry_name = $entry_name key = $key"); 2668 2669 my $html_line; 2670 2671 $html_line = "<tr><div class=\"left\"><td><b> "; 2672 $html_line = "<tr><div class=\"right\"><td><b> "; 2673 $html_line .= $entry_name; 2674 $html_line .= " </b></td>"; 2675 for my $i (sort keys @experiment_data) 2676 { 2677 if (exists ($experiment_data[$i]{$key})) 2678 { 2679 $html_line .= "<td> " . $experiment_data[$i]{$key} . " </td>"; 2680 } 2681 else 2682 { 2683## gp_message ("assertion", $subr_name, "experiment_data[$i]{$key} does not exist"); 2684 gp_message ("warning", $subr_name, "experiment_data[$i]{$key} does not exist"); 2685 } 2686 } 2687 $html_line .= "</div></tr>\n"; 2688 2689 gp_message ("debugXL", $subr_name, "return html_line = $html_line"); 2690 2691 return (\$html_line); 2692 2693} #-- End of subroutine create_table_entry_exp 2694 2695#------------------------------------------------------------------------------- 2696# Create the table header for the experiment info. 2697#------------------------------------------------------------------------------- 2698sub create_table_header_exp 2699{ 2700 my $subr_name = get_my_name (); 2701 2702 my ($experiment_data_ref) = @_; 2703 2704 my @experiment_data = @{ $experiment_data_ref }; 2705 my $html_header_line; 2706 2707 $html_header_line = "<style>\n"; 2708 $html_header_line .= "table, th, td {\n"; 2709 $html_header_line .= "border: 1px solid black;\n"; 2710 $html_header_line .= "border-collapse: collapse;\n"; 2711 $html_header_line .= "}\n"; 2712 $html_header_line .= "</style>\n"; 2713 $html_header_line .= "</pre>\n"; 2714 $html_header_line .= "<table>\n"; 2715 $html_header_line .= "<tr><div class=\"center\"><th></th>"; 2716 2717 for my $i (sort keys @experiment_data) 2718 { 2719 $html_header_line .= "<th> Experiment ID " . $experiment_data[$i]{"exp_id"} . " </th>"; 2720 } 2721 $html_header_line .= "</div></tr>\n"; 2722 2723 gp_message ("debugXL", $subr_name, "html_header_line = $html_header_line"); 2724 2725 return (\$html_header_line); 2726 2727} #-- End of subroutine create_table_header_exp 2728 2729#------------------------------------------------------------------------------- 2730# Handle where the output should go. If needed, a directory is created where 2731# the results will go. 2732#------------------------------------------------------------------------------- 2733sub define_the_output_directory 2734{ 2735 my $subr_name = get_my_name (); 2736 2737 my ($define_new_output_dir, $overwrite_output_dir) = @_; 2738 2739 my $outputdir; 2740 2741#------------------------------------------------------------------------------- 2742# If neither -o or -O are set, find the next number to be used in the name for 2743# the default output directory. 2744#------------------------------------------------------------------------------- 2745 if ((not $define_new_output_dir) and (not $overwrite_output_dir)) 2746 { 2747 my $dir_id = 1; 2748 while (-d "er.".$dir_id.".html") 2749 { $dir_id++; } 2750 $outputdir = "er.".$dir_id.".html"; 2751 } 2752 2753 if (-d $outputdir) 2754 { 2755#------------------------------------------------------------------------------- 2756# The -o option is used, but the directory already exists. 2757#------------------------------------------------------------------------------- 2758 if ($define_new_output_dir) 2759 { 2760 gp_message ("error", $subr_name, "directory $outputdir already exists"); 2761 gp_message ("abort", $subr_name, "use the -O option to overwrite an existing directory"); 2762 } 2763#------------------------------------------------------------------------------- 2764# This is a bit risky, so we proceed with caution. The output directory exists, 2765# but it is okay to overwrite it. It is removed here and created again below. 2766#------------------------------------------------------------------------------- 2767 elsif ($overwrite_output_dir) 2768 { 2769 my $target_cmd = $g_mapped_cmds{"rm"}; 2770 my $rm_output = qx ($target_cmd -rf $outputdir); 2771 my $error_code = ${^CHILD_ERROR_NATIVE}; 2772 if ($error_code != 0) 2773 { 2774 gp_message ("error", $subr_name, $rm_output); 2775 gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir"); 2776 } 2777 else 2778 { 2779 gp_message ("debug", $subr_name, "directory $outputdir has been removed"); 2780 } 2781 } 2782 } 2783#------------------------------------------------------------------------------- 2784# When we get here, the fatal scenarios have been cleared and the name for 2785# $outputdir is known. Time to create it. 2786#------------------------------------------------------------------------------- 2787 if (mkdir ($outputdir, 0777)) 2788 { 2789 gp_message ("debug", $subr_name, "created output directory $outputdir"); 2790 } 2791 else 2792 { 2793 gp_message ("abort", $subr_name, "a fatal problem occurred when creating directory $outputdir"); 2794 } 2795 2796 return ($outputdir); 2797 2798} #-- End of subroutine define_the_output_directory 2799 2800#------------------------------------------------------------------------------ 2801# Return the virtual address for the load object. 2802# 2803# Note that at this point, $elf_arch is known to be supported. 2804# 2805# TBD: Duplications? 2806#------------------------------------------------------------------------------ 2807sub determine_base_va_address 2808{ 2809 my $subr_name = get_my_name (); 2810 2811 my ($executable_name, $base_va_executable, $loadobj, $routine) = @_; 2812 2813 my $name_loadobject; 2814 my $base_va_address; 2815 2816 gp_message ("debugXL", $subr_name, "base_va_executable = $base_va_executable"); 2817 gp_message ("debugXL", $subr_name, "loadobj = $loadobj"); 2818 gp_message ("debugXL", $subr_name, "routine = $routine"); 2819 2820#------------------------------------------------------------------------------ 2821# Strip the pathname from the load object name. 2822#------------------------------------------------------------------------------ 2823 $name_loadobject = get_basename ($loadobj); 2824 2825#------------------------------------------------------------------------------ 2826# If the load object is the executable, return the base address determined 2827# earlier. Otherwise return 0x0. Note that I am not sure if this is always 2828# the right thing to do, but for .so files it seems to work out fine. 2829#------------------------------------------------------------------------------ 2830 if ($name_loadobject eq $executable_name) 2831 { 2832 $base_va_address = $base_va_executable; 2833 } 2834 else 2835 { 2836 $base_va_address = "0x0"; 2837 } 2838 2839 my $decimal_address = bigint::hex ($base_va_address); 2840 gp_message ("debugXL", $subr_name, "return base_va_address = $base_va_address (decimal: $decimal_address)"); 2841 2842 return ($base_va_address); 2843 2844} #-- End of subroutine determine_base_va_address 2845 2846#------------------------------------------------------------------------------- 2847# Now that we know the map.xml file(s) are present, we can scan these and get 2848# the required information. 2849#------------------------------------------------------------------------------- 2850sub determine_base_virtual_address 2851{ 2852 my $subr_name = get_my_name (); 2853 2854 my ($exp_dir_list_ref) = @_; 2855 2856 my @exp_dir_list = @{ $exp_dir_list_ref }; 2857 2858 my $full_path_exec; 2859 my $executable_name; 2860 my $va_executable_in_hex; 2861 2862 my $path_to_map_file; 2863 2864 for my $exp_dir (keys %g_exp_dir_meta_data) 2865 { 2866 $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; 2867 $path_to_map_file .= $exp_dir; 2868 $path_to_map_file .= "/map.xml"; 2869 2870 ($full_path_exec, $executable_name, $va_executable_in_hex) = extract_info_from_map_xml ($path_to_map_file); 2871 2872 $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"} = $full_path_exec; 2873 $g_exp_dir_meta_data{$exp_dir}{"exec_name"} = $executable_name; 2874 $g_exp_dir_meta_data{$exp_dir}{"va_base_in_hex"} = $va_executable_in_hex; 2875 2876 gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); 2877 gp_message ("debug", $subr_name, "full_path_exece = $full_path_exec"); 2878 gp_message ("debug", $subr_name, "executable_name = $executable_name"); 2879 gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex"); 2880 } 2881 2882 return (0); 2883 2884} #-- End of subroutine determine_base_virtual_address 2885 2886#------------------------------------------------------------------------------ 2887# Determine whether the decimal separator is a point or a comma. 2888#------------------------------------------------------------------------------ 2889sub determine_decimal_separator 2890{ 2891 my $subr_name = get_my_name (); 2892 2893 my $ignore_count; 2894 my $decimal_separator; 2895 my $convert_to_dot; 2896 my $field; 2897 my $target_found; 2898 my $error_code; 2899 my $cmd_output; 2900 my $target_cmd; 2901 my @locale_info; 2902 2903 my $default_decimal_separator = "\\."; 2904 2905 $target_cmd = $g_mapped_cmds{locale} . " -k LC_NUMERIC"; 2906 ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); 2907 2908 if ($error_code != 0) 2909#------------------------------------------------------------------------------- 2910# This is unlikely to happen, but you never know. To reduce the nesting level, 2911# return right here in case of an error. 2912#------------------------------------------------------------------------------- 2913 { 2914 gp_message ("error", $subr_name, "failure to execute the command $target_cmd"); 2915 2916 $convert_to_dot = $TRUE; 2917 2918 return ($error_code, $default_decimal_separator, $convert_to_dot); 2919 } 2920 2921#------------------------------------------------------------------------------- 2922# Scan the locale info and search for the target line of the form 2923# decimal_point="<target>" where <target> is either a dot, or a comma. 2924#------------------------------------------------------------------------------- 2925 2926#------------------------------------------------------------------------------- 2927# Split the output into the different lines and scan for the line we need. 2928#------------------------------------------------------------------------------- 2929 @locale_info = split ("\n", $cmd_output); 2930 $target_found = $FALSE; 2931 for my $line (@locale_info) 2932 { 2933 chomp ($line); 2934 gp_message ("debug", $subr_name, "line from locale_info = $line"); 2935 if ($line =~ /decimal_point=/) 2936 { 2937 2938#------------------------------------------------------------------------------- 2939# Found the target line. Split this line to get the value field. 2940#------------------------------------------------------------------------------- 2941 my @split_line = split ("=", $line); 2942 2943#------------------------------------------------------------------------------- 2944# There should be 2 fields. If not, something went wrong. 2945#------------------------------------------------------------------------------- 2946 if (scalar @split_line != 2) 2947 { 2948# if (scalar @split_line == 2) { 2949# $target_found = $FALSE; 2950#------------------------------------------------------------------------------- 2951# Remove the newline before printing the variables. 2952#------------------------------------------------------------------------------- 2953 $ignore_count = chomp ($line); 2954 $ignore_count = chomp (@split_line); 2955 gp_message ("debug", $subr_name, "warning - line $line matches the search, but the decimal separator has the wrong format"); 2956 gp_message ("debug", $subr_name, "warning - the splitted line is [@split_line] and does not contain 2 fields"); 2957 gp_message ("debug", $subr_name, "warning - the default decimal separator will be used"); 2958 } 2959 else 2960 { 2961#------------------------------------------------------------------------------- 2962# We know there are 2 fields and the second one has the decimal point. 2963#------------------------------------------------------------------------------- 2964 gp_message ("debug", $subr_name, "split_line[1] = $split_line[1]"); 2965 2966 chomp ($split_line[1]); 2967 $field = $split_line[1]; 2968 2969 if (length ($field) != 3) 2970#------------------------------------------------------------------------------- 2971# The field still includes the quotes. Check if the string has length 3, which 2972# should be the case, but if not, we flag an error. The error code is set such 2973# that the callee will know a problem has occurred. 2974#------------------------------------------------------------------------------- 2975 { 2976 gp_message ("error", $subr_name, "unexpected output from the $target_cmd command: $field"); 2977 $error_code = 1; 2978 last; 2979 } 2980 2981 gp_message ("debug", $subr_name, "field = ->$field<-"); 2982 2983 if (($field eq "\".\"") or ($field eq "\",\"")) 2984#------------------------------------------------------------------------------- 2985# Found the separator. Capture the character between the quotes. 2986#------------------------------------------------------------------------------- 2987 { 2988 $target_found = $TRUE; 2989 $decimal_separator = substr ($field,1,1); 2990 gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator--end skip loop"); 2991 last; 2992 } 2993 } 2994 } 2995 } 2996 if (not $target_found) 2997 { 2998 $decimal_separator = $default_decimal_separator; 2999 gp_message ("warning", $subr_name, "cannot determine the decimal separator - use the default $decimal_separator"); 3000 } 3001 3002 if ($decimal_separator ne ".") 3003 { 3004 $convert_to_dot = $TRUE; 3005 } 3006 else 3007 { 3008 $convert_to_dot = $FALSE; 3009 } 3010 3011 $decimal_separator = "\\".$decimal_separator; 3012 $g_locale_settings{"decimal_separator"} = $decimal_separator; 3013 $g_locale_settings{"convert_to_dot"} = $convert_to_dot; 3014 3015 return ($error_code, $decimal_separator, $convert_to_dot); 3016 3017} #-- End of subroutine determine_decimal_separator 3018 3019#------------------------------------------------------------------------------ 3020# TBD 3021#------------------------------------------------------------------------------ 3022sub dump_function_info 3023{ 3024 my $subr_name = get_my_name (); 3025 3026 my ($function_info_ref, $name) = @_; 3027 3028 my %function_info = %{$function_info_ref}; 3029 my $kip; 3030 3031 gp_message ("debug", $subr_name, "function_info for $name"); 3032 $kip = 0; 3033 for my $farray ($function_info{$name}) 3034 { 3035 for my $elm (@{$farray}) 3036 { 3037 gp_message ("debug", $subr_name, "$kip: routine = ${$elm}{'routine'}"); 3038 for my $key (sort keys %{$elm}) 3039 { 3040 if ($key eq "routine") 3041 { 3042 next; 3043 } 3044 gp_message ("debug", $subr_name, "$kip: $key = ${$elm}{$key}"); 3045 } 3046 $kip++; 3047 } 3048 } 3049 3050 return (0); 3051 3052} #-- End of subroutine dump_function_info 3053 3054#------------------------------------------------------------------------------ 3055# This is an early scan to find the settings for some options very early on. 3056# For practical reasons the main option parsing and handling is done later, 3057# but without this early scan, these options will not be enabled until later 3058# in the execution. 3059# 3060# This early scan fixes that, but it is not very elegant to do it this way 3061# and in the future, this will be improved. For now it gets the job done. 3062#------------------------------------------------------------------------------ 3063sub early_scan_specific_options 3064{ 3065 my $subr_name = get_my_name (); 3066 3067 my @options_with_value = qw /verbose warnings debug quiet/; 3068 my $target_option; 3069 3070 my $ignore_value; 3071 my $found_option; 3072 my $option_requires_value; 3073 my $option_value; 3074 my $valid_input; 3075 my @error_messages = (); 3076 3077 $option_requires_value = $TRUE; 3078 for (@options_with_value) 3079 { 3080 $target_option = $_; 3081 ($found_option, $option_value) = find_target_option ( 3082 \@ARGV, 3083 $option_requires_value, 3084 $target_option); 3085 if ($found_option) 3086 { 3087#------------------------------------------------------------------------------ 3088# This part has been set up such that we can support other options too, should 3089# this become necessary. 3090# 3091# A necessary, but limited check for the validity of a value is performed. 3092# This avoids that an error message shows up twice later on. 3093#------------------------------------------------------------------------------ 3094 3095#------------------------------------------------------------------------------ 3096# All option values are converted to lower case. This makes the checks easier. 3097#------------------------------------------------------------------------------ 3098 3099 if ($target_option eq "verbose") 3100 { 3101 my $verbose_value = lc ($option_value); 3102 $valid_input = verify_if_input_is_valid ($verbose_value, "onoff"); 3103 if ($valid_input) 3104 { 3105 $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE; 3106 if ($verbose_value eq "on") 3107#------------------------------------------------------------------------------ 3108# Set the status and disable output buffering in verbose mode. 3109#------------------------------------------------------------------------------ 3110 { 3111 $g_user_settings{"verbose"}{"current_value"} = "on"; 3112 STDOUT->autoflush (1); 3113 } 3114 elsif ($verbose_value eq "off") 3115 { 3116 $g_user_settings{"verbose"}{"current_value"} = "off"; 3117 } 3118 } 3119 else 3120 { 3121 my $msg = "$option_value is not supported for the verbose option"; 3122 push (@error_messages, $msg); 3123 } 3124 } 3125 elsif ($target_option eq "warnings") 3126 { 3127 my $warnings_value = lc ($option_value); 3128 $valid_input = verify_if_input_is_valid ($warnings_value, "onoff"); 3129 if ($valid_input) 3130 { 3131 $g_warnings = ($warnings_value eq "on") ? $TRUE : $FALSE; 3132 if ($warnings_value eq "on") 3133#------------------------------------------------------------------------------ 3134# Set the status and disable output buffering if warnings are enabled. 3135#------------------------------------------------------------------------------ 3136 { 3137 $g_user_settings{"warnings"}{"current_value"} = "on"; 3138 STDOUT->autoflush (1); 3139 } 3140 elsif ($warnings_value eq "off") 3141 { 3142 $g_user_settings{"warnings"}{"current_value"} = "off"; 3143 } 3144 } 3145 else 3146 { 3147 my $msg = "$option_value is not supported for the warnings option"; 3148 push (@error_messages, $msg); 3149 } 3150 } 3151 elsif ($target_option eq "quiet") 3152 { 3153 my $quiet_value = lc ($option_value); 3154 $valid_input = verify_if_input_is_valid ($option_value, "onoff"); 3155 if ($valid_input) 3156 { 3157 $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE; 3158 if ($quiet_value eq "on") 3159 { 3160 $g_user_settings{"quiet"}{"current_value"} = "on"; 3161 } 3162 elsif ($quiet_value eq "off") 3163 { 3164 $g_user_settings{"quiet"}{"current_value"} = "off"; 3165 } 3166 } 3167 else 3168 { 3169 my $msg = "$option_value is not supported for the quiet option"; 3170 push (@error_messages, $msg); 3171 } 3172 } 3173 elsif ($target_option eq "debug") 3174 { 3175 my $debug_value = lc ($option_value); 3176 $valid_input = verify_if_input_is_valid ($debug_value, "size"); 3177 if ($valid_input) 3178 { 3179 if ($debug_value ne "off") 3180#------------------------------------------------------------------------------ 3181# Disable output buffering in debug mode. 3182#------------------------------------------------------------------------------ 3183 { 3184 $g_user_settings{"debug"}{"current_value"} = "on"; 3185 STDOUT->autoflush (1); 3186 } 3187#------------------------------------------------------------------------------ 3188# This function also sets $g_user_settings{"debug"}{"current_value"}. 3189#------------------------------------------------------------------------------ 3190 my $ignore_value = set_debug_size (\$debug_value); 3191 } 3192 else 3193 { 3194 my $msg = "$option_value is not supported for the debug option"; 3195 push (@error_messages, $msg); 3196 } 3197 } 3198 else 3199 { 3200 my $msg = "target option $target_option not expected"; 3201 gp_message ("assertion", $subr_name, $msg); 3202 } 3203 } 3204 } 3205 3206#------------------------------------------------------------------------------ 3207# Check for input errors. 3208#------------------------------------------------------------------------------ 3209 my $input_errors = scalar (@error_messages); 3210 if ($input_errors > 0) 3211 { 3212 my $plural = ($input_errors == 1) ? 3213 "is one error" : "are $input_errors errors"; 3214 print "There " . $plural . " in the options:\n"; 3215 for my $i (0 .. $#error_messages) 3216 { 3217 print "- $error_messages[$i]\n"; 3218 } 3219 exit (0); 3220 } 3221#------------------------------------------------------------------------------ 3222# If quiet mode has been enabled, disable verbose, warnings and debug. 3223#------------------------------------------------------------------------------ 3224 if ($g_quiet) 3225 { 3226 $g_user_settings{"verbose"}{"current_value"} = "off"; 3227 $g_user_settings{"warnings"}{"current_value"} = "off"; 3228 $g_user_settings{"debug"}{"current_value"} = "off"; 3229 $g_verbose = $FALSE; 3230 $g_warnings = $FALSE; 3231 my $debug_off = "off"; 3232 my $ignore_value = set_debug_size (\$debug_off); 3233 } 3234 3235 return (0); 3236 3237} #-- End of subroutine early_scan_specific_options 3238 3239#------------------------------------------------------------------------------ 3240# TBD 3241#------------------------------------------------------------------------------ 3242sub elf_phdr 3243{ 3244 my $subr_name = get_my_name (); 3245 3246 my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine, 3247 $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_; 3248 3249 my %elf_rats = %{$elf_rats_ref}; 3250 3251 my $return_value; 3252 3253#------------------------------------------------------------------------------ 3254# TBD. Quick check. Can be moved up the call tree. 3255#------------------------------------------------------------------------------ 3256 if ( ($elf_arch ne "Linux") and ($elf_arch ne "SunOS") ) 3257 { 3258 gp_message ("abort", $subr_name, "$elf_arch is not a supported OS"); 3259 } 3260 3261#------------------------------------------------------------------------------ 3262# TBD: This should not be in a loop over $loadobj and only use the executable. 3263#------------------------------------------------------------------------------ 3264 3265#------------------------------------------------------------------------------ 3266# TBD: $routine is not really used in these subroutines. Is this a bug? 3267#------------------------------------------------------------------------------ 3268 if ($elf_loadobjects_found) 3269 { 3270 gp_message ("debugXL", $subr_name, "calling elf_phdr_usual"); 3271 $return_value = elf_phdr_usual ($elf_arch, $loadobj, $routine, \%elf_rats); 3272 } 3273 else 3274 { 3275 gp_message ("debugXL", $subr_name, "calling elf_phdr_sometimes"); 3276 $return_value = elf_phdr_sometimes ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR); 3277 } 3278 3279 gp_message ("debug", $subr_name, "the return value = $return_value"); 3280 3281 if (not $return_value) 3282 { 3283 gp_message ("abort", $subr_name, "need to handle a return value of FALSE"); 3284 } 3285 return ($return_value); 3286 3287} #-- End of subroutine elf_phdr 3288 3289#------------------------------------------------------------------------------ 3290# Return the virtual address for the load object. 3291#------------------------------------------------------------------------------ 3292sub elf_phdr_sometimes 3293{ 3294 my $subr_name = get_my_name (); 3295 3296 my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, 3297 $ARCHIVES_MAP_VADDR) = @_; 3298 3299 my $arch_uname_s = $local_system_config{"kernel_name"}; 3300 my $arch_uname = $local_system_config{"processor"}; 3301 my $arch = $g_arch_specific_settings{"arch"}; 3302 3303 gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s"); 3304 gp_message ("debug", $subr_name, "arch_uname = $arch_uname"); 3305 gp_message ("debug", $subr_name, "arch = $arch"); 3306 3307 my $target_cmd; 3308 my $command_string; 3309 my $error_code; 3310 my $cmd_output; 3311 3312 my $line; 3313 my $blo; 3314 3315 my $elf_offset; 3316 my $i; 3317 my @foo; 3318 my $foo; 3319 my $foo1; 3320 my $p_vaddr; 3321 my $rc; 3322 my $archives_file; 3323 my $loadobj_SAVE; 3324 my $Offset; 3325 my $VirtAddr; 3326 my $PhysAddr; 3327 my $FileSiz; 3328 my $MemSiz; 3329 my $Flg; 3330 my $Align; 3331 3332 if ($ARCHIVES_MAP_NAME eq $blo) 3333 { 3334 return ($ARCHIVES_MAP_VADDR); 3335 } 3336 else 3337 { 3338 return ($FALSE); 3339 } 3340 3341 if ($arch_uname_s ne $elf_arch) 3342 { 3343#------------------------------------------------------------------------------ 3344# We are masquerading between systems, must leave 3345#------------------------------------------------------------------------------ 3346 gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"); 3347 return ($FALSE); 3348 } 3349 if ($loadobj eq "DYNAMIC_FUNCTIONS") 3350#------------------------------------------------------------------------------ 3351# Linux vDSO, leave for now 3352#------------------------------------------------------------------------------ 3353 { 3354 return ($FALSE); 3355 } 3356 3357# TBD: STILL NEEDED??!! 3358 3359 $loadobj_SAVE = $loadobj; 3360 3361 $blo = get_basename ($loadobj); 3362 gp_message ("debug", $subr_name, "loadobj = $loadobj"); 3363 gp_message ("debug", $subr_name, "blo = $blo"); 3364 gp_message ("debug", $subr_name, "ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"); 3365 gp_message ("debug", $subr_name, "ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"); 3366 if ($ARCHIVES_MAP_NAME eq $blo) 3367 { 3368 return ($ARCHIVES_MAP_VADDR); 3369 } 3370 else 3371 { 3372 return ($FALSE); 3373 } 3374 3375} #-- End of subroutine elf_phdr_sometimes 3376 3377#------------------------------------------------------------------------------ 3378# Return the virtual address for the load object. 3379# 3380# Note that at this point, $elf_arch is known to be supported. 3381#------------------------------------------------------------------------------ 3382sub elf_phdr_usual 3383{ 3384 my $subr_name = get_my_name (); 3385 3386 my ($elf_arch, $loadobj, $routine, $elf_rats_ref) = @_; 3387 3388 my %elf_rats = %{$elf_rats_ref}; 3389 3390 my $return_code; 3391 my $cmd_output; 3392 my $target_cmd; 3393 my $command_string; 3394 my $error_code; 3395 my $error_code1; 3396 my $error_code2; 3397 3398 my ($elf_offset, $loadobjARC); 3399 my ($i, @foo, $foo, $foo1, $p_vaddr, $rc); 3400 my ($Offset, $VirtAddr, $PhysAddr, $FileSiz, $MemSiz, $Flg, $Align); 3401 3402 my $arch_uname_s = $local_system_config{"kernel_name"}; 3403 3404 gp_message ("debug", $subr_name, "elf_arch = $elf_arch loadobj = $loadobj routine = $routine"); 3405 3406 my ($base, $ignore_value, $ignore_too) = fileparse ($loadobj); 3407 gp_message ("debug", $subr_name, "base = $base ".basename ($loadobj)); 3408 3409 if ($elf_arch eq "Linux") 3410 { 3411 if ($arch_uname_s ne $elf_arch) 3412 { 3413#------------------------------------------------------------------------------ 3414# We are masquerading between systems, must leave. 3415# Maybe we could use ELF_RATS 3416#------------------------------------------------------------------------------ 3417 gp_message ("debug", $subr_name, "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"); 3418 return ($FALSE); 3419 } 3420 if ($loadobj eq "DYNAMIC_FUNCTIONS") 3421 { 3422#------------------------------------------------------------------------------ 3423# Linux vDSO, leave for now 3424#------------------------------------------------------------------------------ 3425 gp_message ("debug", $subr_name, "early return: loadobj = $loadobj"); 3426 return ($FALSE); 3427 } 3428 3429 $target_cmd = $g_mapped_cmds{"readelf"}; 3430 $command_string = $target_cmd . " -l " . $loadobj . " 2>/dev/null"; 3431 3432 ($error_code1, $cmd_output) = execute_system_cmd ($command_string); 3433 3434 gp_message ("debug", $subr_name, "executed command_string = $command_string"); 3435 gp_message ("debug", $subr_name, "cmd_output = $cmd_output"); 3436 3437 if ($error_code1 != 0) 3438 { 3439 gp_message ("debug", $subr_name, "call failure for $command_string"); 3440#------------------------------------------------------------------------------ 3441# e.g. $loadobj->/usr/lib64/libc-2.17.so 3442#------------------------------------------------------------------------------ 3443 $loadobjARC = get_basename ($loadobj); 3444 gp_message ("debug", $subr_name, "seek elf_rats for $loadobjARC"); 3445 3446 if (exists ($elf_rats{$loadobjARC})) 3447 { 3448 my $elfoid = "$elf_rats{$loadobjARC}[1]/archives/$elf_rats{$loadobjARC}[0]"; 3449 $target_cmd = $g_mapped_cmds{"readelf"}; 3450 $command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null"; 3451 ($error_code2, $cmd_output) = execute_system_cmd ($command_string); 3452 3453 if ($error_code2 != 0) 3454 { 3455 gp_message ("abort", $subr_name, "call failure for $command_string"); 3456 } 3457 else 3458 { 3459 gp_message ("debug", $subr_name, "executed command_string = $command_string"); 3460 gp_message ("debug", $subr_name, "cmd_output = $cmd_output"); 3461 } 3462 } 3463 else 3464 { 3465 my $msg = "elf_rats{$loadobjARC} does not exist"; 3466 gp_message ("assertion", $subr_name, $msg); 3467 } 3468 } 3469#------------------------------------------------------------------------------ 3470# Example output of "readelf -l" on Linux: 3471# 3472# Elf file type is EXEC (Executable file) 3473# Entry point 0x4023a0 3474# There are 11 program headers, starting at offset 64 3475# 3476# Program Headers: 3477# Type Offset VirtAddr PhysAddr 3478# FileSiz MemSiz Flags Align 3479# PHDR 0x0000000000000040 0x0000000000400040 0x0000000000400040 3480# 0x0000000000000268 0x0000000000000268 R 8 3481# INTERP 0x00000000000002a8 0x00000000004002a8 0x00000000004002a8 3482# 0x000000000000001c 0x000000000000001c R 1 3483# [Requesting program interpreter: /lib64/ld-linux-x86-64.so.2] 3484# LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000 3485# 0x0000000000001310 0x0000000000001310 R 1000 3486# LOAD 0x0000000000002000 0x0000000000402000 0x0000000000402000 3487# 0x0000000000006515 0x0000000000006515 R E 1000 3488# LOAD 0x0000000000009000 0x0000000000409000 0x0000000000409000 3489# 0x000000000006f5a8 0x000000000006f5a8 R 1000 3490# LOAD 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8 3491# 0x000000000000047c 0x0000000000000f80 RW 1000 3492# DYNAMIC 0x0000000000078dd8 0x0000000000479dd8 0x0000000000479dd8 3493# 0x0000000000000220 0x0000000000000220 RW 8 3494# NOTE 0x00000000000002c4 0x00000000004002c4 0x00000000004002c4 3495# 0x0000000000000044 0x0000000000000044 R 4 3496# GNU_EH_FRAME 0x00000000000777f4 0x00000000004777f4 0x00000000004777f4 3497# 0x000000000000020c 0x000000000000020c R 4 3498# GNU_STACK 0x0000000000000000 0x0000000000000000 0x0000000000000000 3499# 0x0000000000000000 0x0000000000000000 RW 10 3500# GNU_RELRO 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8 3501# 0x0000000000000238 0x0000000000000238 R 1 3502# 3503# Section to Segment mapping: 3504# Segment Sections... 3505# 00 3506# 01 .interp 3507# 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt 3508# 03 .init .plt .text .fini 3509# 04 .rodata .eh_frame_hdr .eh_frame 3510# 05 .init_array .fini_array .dynamic .got .got.plt .data .bss 3511# 06 .dynamic 3512# 07 .note.gnu.build-id .note.ABI-tag 3513# 08 .eh_frame_hdr 3514# 09 3515# 10 .init_array .fini_array .dynamic .got 3516#------------------------------------------------------------------------------ 3517 3518#------------------------------------------------------------------------------ 3519# Analyze the ELF information and try to find the virtual address. 3520# 3521# Note that the information printed as part of LOAD needs to have "R E" in it. 3522# In the example output above, the return value would be "0x0000000000402000". 3523# 3524# We also need to distinguish two cases. It could be that the output is on 3525# a single line, or spread over two lines: 3526# 3527# Offset VirtAddr PhysAddr FileSiz MemSiz Flg Align 3528# LOAD 0x000000 0x08048000 0x08048000 0x61b4ae 0x61b4ae R E 0x1000 3529# or 2 lines 3530# LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000 3531# 0x0000000000001010 0x0000000000001010 R E 200000 3532#------------------------------------------------------------------------------ 3533 @foo = split ("\n",$cmd_output); 3534 for $i (0 .. $#foo) 3535 { 3536 $foo = $foo[$i]; 3537 chomp ($foo); 3538 if ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/) 3539 { 3540 $Offset = $1; 3541 $VirtAddr = $2; 3542 $PhysAddr = $3; 3543 $FileSiz = $4; 3544 $MemSiz = $5; 3545 $Flg = $6; 3546 $Align = $7; 3547 3548 $elf_offset = $VirtAddr; 3549 gp_message ("debug", $subr_name, "single line version elf_offset = $elf_offset"); 3550 return ($elf_offset); 3551 } 3552 elsif ($foo =~ /^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$/) 3553 { 3554#------------------------------------------------------------------------------ 3555# is it a two line version? 3556#------------------------------------------------------------------------------ 3557 $Offset = $1; 3558 $VirtAddr = $2; # maybe 3559 $PhysAddr = $3; 3560 if ($i != $#foo) 3561 { 3562 $foo1 = $foo[$i + 1]; 3563 chomp ($foo1); 3564 if ($foo1 =~ /^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$/) 3565 { 3566 $FileSiz = $1; 3567 $MemSiz = $2; 3568 $Flg = $3; 3569 $Align = $4; 3570 $elf_offset = $VirtAddr; 3571 gp_message ("debug", $subr_name, "two line version elf_offset = $elf_offset"); 3572 return ($elf_offset); 3573 } 3574 } 3575 } 3576 } 3577 } 3578 elsif ($elf_arch eq "SunOS") 3579 { 3580#------------------------------------------------------------------------------ 3581#Program Header[3]: 3582# p_vaddr: 0x10000 p_flags: [ PF_X PF_R ] 3583# folowed by 3584# p_paddr: 0 p_type: [ PT_LOAD ] 3585#------------------------------------------------------------------------------ 3586 if ($arch_uname_s ne $elf_arch) 3587#------------------------------------------------------------------------------ 3588# we are masquerading between systems, must leave 3589#------------------------------------------------------------------------------ 3590 { 3591 gp_message ("debug", $subr_name,"masquerading arch_uname_s = $arch_uname_s elf_arch = $elf_arch"); 3592 return (0); 3593 } 3594 $target_cmd = $g_mapped_cmds{"elfdump"}; 3595 $command_string = $target_cmd . "-p " . $loadobj . " 2>/dev/null"; 3596 ($error_code, $cmd_output) = execute_system_cmd ($command_string); 3597 if ($error_code != 0) 3598 { 3599 gp_message ("debug", $subr_name,"call failure for $command_string"); 3600 die ("$target_cmd call failure"); 3601 } 3602 my @foo = split ("\n",$cmd_output); 3603 for $i (0 .. $#foo) 3604 { 3605 $foo = $foo[$i]; 3606 chomp ($foo); 3607 if ($foo =~ /^\s+p_vaddr:\s+(\S+)\s+p_flags:\s+\[\sPF_X\sPF_R\s\]$/) 3608 { 3609 $p_vaddr = $1; # probably 3610 if ($i != $#foo) 3611 { 3612 $foo1 = $foo[$i + 1]; 3613 chomp ($foo1); 3614 if ($foo1 =~ /^\s+p_paddr:\s+(\S+)\s+p_type:\s+\[\sPT_LOAD\s\]$/) 3615 { 3616 $elf_offset = $p_vaddr; 3617 return ($elf_offset); 3618 } 3619 } 3620 } 3621 } 3622 } 3623 3624} #-- End of subroutine elf_phdr_usual 3625 3626#------------------------------------------------------------------------------ 3627# Execute a system command. In case of an error, a non-zero error code is 3628# returned. It is upon the caller to decide what to do next. 3629#------------------------------------------------------------------------------ 3630sub execute_system_cmd 3631{ 3632 my $subr_name = get_my_name (); 3633 3634 my ($target_cmd) = @_; 3635 3636 chomp ($target_cmd); 3637 3638 my $cmd_output = qx ($target_cmd); 3639 my $error_code = ${^CHILD_ERROR_NATIVE}; 3640 3641 if ($error_code != 0) 3642 { 3643 gp_message ("error", $subr_name, "failure executing command $target_cmd"); 3644 gp_message ("error", $subr_name, "error code = $error_code"); 3645 } 3646 else 3647 { 3648 chomp ($cmd_output); 3649 gp_message ("debugM", $subr_name, "executed command $target_cmd"); 3650 gp_message ("debugM", $subr_name, "cmd_output = $cmd_output"); 3651 } 3652 3653 return ($error_code, $cmd_output); 3654 3655} #-- End of subroutine execute_system_cmd 3656 3657#------------------------------------------------------------------------------ 3658# Scan the input file, which should be a gprofng generated map.xml file, and 3659# extract the relevant information. 3660#------------------------------------------------------------------------------ 3661sub extract_info_from_map_xml 3662{ 3663 my $subr_name = get_my_name (); 3664 3665 my ($input_map_xml_file) = @_; 3666 3667 my $extracted_information; 3668 my $input_line; 3669 my $vaddr; 3670 my $foffset; 3671 my $modes; 3672 my $name_path; 3673 my $name; 3674 3675 my $full_path_exec; 3676 my $executable_name; 3677 my $va_executable_in_hex; 3678 3679 open (MAP_XML, "<", $input_map_xml_file) 3680 or die ("$subr_name - unable to open file $input_map_xml_file for reading: $!"); 3681 gp_message ("debug", $subr_name, "opened file $input_map_xml_file for reading"); 3682 3683#------------------------------------------------------------------------------ 3684# Scan the file. We need to find the name of the executable with the mode set 3685# to 0x005. For this entry we have to capture the name, the mode, the virtual 3686# address and the offset. 3687#------------------------------------------------------------------------------ 3688 $extracted_information = $FALSE; 3689 while (<MAP_XML>) 3690 { 3691 $input_line = $_; 3692 chomp ($input_line); 3693 gp_message ("debug", $subr_name, "read input_line = $input_line"); 3694 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="(.*)".*>$/) 3695 { 3696 gp_message ("debug", $subr_name, "target line = $input_line"); 3697 3698 $vaddr = $1; 3699 $foffset = $2; 3700 $modes = $3; 3701 $name_path = $4; 3702 $name = get_basename ($name_path); 3703 gp_message ("debug", $subr_name, "extracted vaddr = $vaddr foffset = $foffset modes = $modes"); 3704 gp_message ("debug", $subr_name, "extracted name_path = $name_path name = $name"); 3705 3706#------------------------------------------------------------------------------ 3707# The base virtual address is calculated as vaddr-foffset. Although Perl 3708# handles arithmetic in hex, we take the safe way here. Maybe overkill, but 3709# I prefer to be safe than sorry in cases like this. 3710#------------------------------------------------------------------------------ 3711 $full_path_exec = $name_path; 3712 $executable_name = $name; 3713 my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); 3714 $va_executable_in_hex = sprintf ("0x%016x", $result_VA); 3715 3716## $ARCHIVES_MAP_NAME = $name; 3717## $ARCHIVES_MAP_VADDR = $va_executable_in_hex; 3718 3719## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"); 3720## gp_message ("debug", $subr_name, "set ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"); 3721 gp_message ("debug", $subr_name, "result_VA = $result_VA"); 3722 gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex"); 3723 3724#------------------------------------------------------------------------------ 3725# Stop reading when we found the correct entry. 3726#------------------------------------------------------------------------------ 3727 if ($modes eq "005") 3728 { 3729 $extracted_information = $TRUE; 3730 last; 3731 } 3732 } 3733 } #-- End of while-loop 3734 3735 if (not $extracted_information) 3736 { 3737 my $msg = "cannot find the necessary information in file $input_map_xml_file"; 3738 gp_message ("assertion", $subr_name, $msg); 3739 } 3740 3741 gp_message ("debug", $subr_name, "full_path_exec = $full_path_exec"); 3742 gp_message ("debug", $subr_name, "executable_name = $executable_name"); 3743 gp_message ("debug", $subr_name, "va_executable_in_hex = $va_executable_in_hex"); 3744 3745 return ($full_path_exec, $executable_name, $va_executable_in_hex); 3746 3747} #-- End of subroutine extract_info_from_map_xml 3748 3749#------------------------------------------------------------------------------ 3750# This routine analyzes the metric line and extracts the metric specifics 3751# from it. 3752# Example input: Exclusive Total CPU Time: e.%totalcpu 3753#------------------------------------------------------------------------------ 3754sub extract_metric_specifics 3755{ 3756 my $subr_name = get_my_name (); 3757 3758 my ($metric_line) = @_; 3759 3760 my $metric_description; 3761 my $metric_flavor; 3762 my $metric_visibility; 3763 my $metric_name; 3764 my $metric_spec; 3765 3766# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){ 3767 if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/)) 3768 { 3769 gp_message ("debug", $subr_name, "line of interest: $metric_line"); 3770 3771 $metric_description = $1; 3772 $metric_flavor = $2; 3773 $metric_visibility = $3; 3774 $metric_name = $4; 3775 3776#------------------------------------------------------------------------------ 3777# Although we have captured the metric visibility, the original code removes 3778# this from the name. Since the structure is more complicated, the code is 3779# more tedious as well. With our new approach we just leave the visibility 3780# out. 3781#------------------------------------------------------------------------------ 3782# $metric_spec = $metric_flavor.$metric_visibility.$metric_name; 3783 3784 $metric_spec = $metric_flavor . "." . $metric_name; 3785 3786#------------------------------------------------------------------------------ 3787# From the original code: 3788# 3789# On x64 systems there are metrics which contain ~ (for example 3790# DC_access~umask=0 . When er_print lists them, they come out 3791# as DC_access%7e%umask=0 (see 6530691). Untill 6530691 is 3792# fixed, we need this. Later we may need something else, or 3793# things may just work. 3794#------------------------------------------------------------------------------ 3795# $metric_spec=~s/\%7e\%/,/; 3796# # remove % metric 3797# print "DB: before \$metric_spec = $metric_spec\n"; 3798 3799#------------------------------------------------------------------------------ 3800# TBD: I don't know why the "%" symbol is removed. 3801#------------------------------------------------------------------------------ 3802# $metric_spec =~ s/\%//; 3803# print "DB: after \$metric_spec = $metric_spec\n"; 3804 3805 return ($metric_spec, $metric_flavor, $metric_visibility, 3806 $metric_name, $metric_description); 3807 } 3808 else 3809 { 3810 return ("skipped", "void"); 3811 } 3812 3813} #-- End of subroutine extract_metric_specifics 3814 3815#------------------------------------------------------------------------------ 3816# TBD 3817#------------------------------------------------------------------------------ 3818sub extract_source_line_number 3819{ 3820 my $subr_name = get_my_name (); 3821 3822 my ($src_times_regex, $function_regex, $number_of_metrics, $input_line) = @_; 3823 3824#------------------------------------------------------------------------------ 3825# The regex section. 3826#------------------------------------------------------------------------------ 3827 my $find_dot_regex = '\.'; 3828 3829 my @fields_in_line = (); 3830 my $hot_line; 3831 my $line_id; 3832 3833#------------------------------------------------------------------------------ 3834# To extract the source line number, we need to distinguish whether this is 3835# a line with, or without metrics. 3836#------------------------------------------------------------------------------ 3837 @fields_in_line = split (" ", $input_line); 3838 if ( $input_line =~ /$src_times_regex/ ) 3839 { 3840 $hot_line = $1; 3841 if ($hot_line eq "##") 3842#------------------------------------------------------------------------------ 3843# The line id comes after the "##" symbol and the metrics. 3844#------------------------------------------------------------------------------ 3845 { 3846 $line_id = $fields_in_line[$number_of_metrics+1]; 3847 } 3848 else 3849#------------------------------------------------------------------------------ 3850# The line id comes after the metrics. 3851#------------------------------------------------------------------------------ 3852 { 3853 $line_id = $fields_in_line[$number_of_metrics]; 3854 } 3855 } 3856 elsif ($input_line =~ /$function_regex/) 3857 { 3858 $line_id = "func"; 3859 } 3860 else 3861#------------------------------------------------------------------------------ 3862# The line id is the first non-blank element. 3863#------------------------------------------------------------------------------ 3864 { 3865 $line_id = $fields_in_line[0]; 3866 } 3867#------------------------------------------------------------------------------ 3868# Remove the trailing dot. 3869#------------------------------------------------------------------------------ 3870 $line_id =~ s/$find_dot_regex//; 3871 3872 return ($line_id); 3873 3874} #-- End of subroutine extract_source_line_number 3875 3876#------------------------------------------------------------------------------ 3877# For a give routine name and address, find the index into the 3878# function_info array 3879#------------------------------------------------------------------------------ 3880sub find_index_in_function_info 3881{ 3882 my $subr_name = get_my_name (); 3883 3884 my ($routine_ref, $current_address_ref, $function_info_ref) = @_; 3885 3886 my $routine = ${ $routine_ref }; 3887 my $current_address = ${ $current_address_ref }; 3888 my @function_info = @{ $function_info_ref }; 3889 3890 my $addr_offset; 3891 my $ref_index; 3892 3893 gp_message ("debugXL", $subr_name, "find index for routine = $routine and current_address = $current_address"); 3894 if (exists ($g_multi_count_function{$routine})) 3895 { 3896 3897# TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!! 3898 3899 gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); 3900 for my $ref (keys @{ $g_map_function_to_index{$routine} }) 3901 { 3902 $ref_index = $g_map_function_to_index{$routine}[$ref]; 3903 3904 gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); 3905 gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); 3906 3907 $addr_offset = $function_info[$ref_index]{"addressobjtext"}; 3908 gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); 3909 3910 $addr_offset =~ s/^@\d+://; 3911 gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); 3912 if ($addr_offset eq $current_address) 3913 { 3914 last; 3915 } 3916 } 3917 } 3918 else 3919 { 3920#------------------------------------------------------------------------------ 3921# There is only a single occurrence and it is straightforward to get the index. 3922#------------------------------------------------------------------------------ 3923 if (exists ($g_map_function_to_index{$routine})) 3924 { 3925 $ref_index = $g_map_function_to_index{$routine}[0]; 3926 } 3927 else 3928 { 3929 my $msg = "index for $routine cannot be determined"; 3930 gp_message ("assertion", $subr_name, $msg); 3931 } 3932 } 3933 3934 gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address ref_index = $ref_index"); 3935 3936 return (\$ref_index); 3937 3938} #-- End of subroutine find_index_in_function_info 3939 3940#------------------------------------------------------------------------------ 3941# TBD 3942#------------------------------------------------------------------------------ 3943sub find_keyword_in_string 3944{ 3945 my $subr_name = get_my_name (); 3946 3947 my ($target_string_ref, $target_keyword_ref) = @_; 3948 3949 my $target_string = ${ $target_string_ref }; 3950 my $target_keyword = ${ $target_keyword_ref }; 3951 my $foundit = $FALSE; 3952 3953 my @index_values = (); 3954 3955 my $ret_val = 0; 3956 my $offset = 0; 3957 gp_message ("debugXL", $subr_name, "target_string = $target_string"); 3958 $ret_val = index ($target_string, $target_keyword, $offset); 3959 gp_message ("debugXL", $subr_name, "ret_val = $ret_val"); 3960 3961 if ($ret_val != -1) 3962 { 3963 $foundit = $TRUE; 3964 while ($ret_val != -1) 3965 { 3966 push (@index_values, $ret_val); 3967 $offset = $ret_val + 1; 3968 gp_message ("debugXL", $subr_name, "ret_val = $ret_val offset = $offset"); 3969 $ret_val = index ($target_string, $target_keyword, $offset); 3970 } 3971 for my $i (keys @index_values) 3972 { 3973 gp_message ("debugXL", $subr_name, "index_values[$i] = $index_values[$i]"); 3974 } 3975 } 3976 else 3977 { 3978 gp_message ("debugXL", $subr_name, "target keyword $target_keyword not found"); 3979 } 3980 3981 return (\$foundit, \@index_values); 3982 3983} #-- End of subroutine find_keyword_in_string 3984 3985#------------------------------------------------------------------------------ 3986# Retrieve the absolute path that was used to execute the command. This path 3987# is used to execute gp-display-text later on. 3988#------------------------------------------------------------------------------ 3989sub find_path_to_gp_display_text 3990{ 3991 my $subr_name = get_my_name (); 3992 3993 my ($full_command_ref) = @_; 3994 3995 my $full_command = ${ $full_command_ref }; 3996 3997 my $error_occurred = $TRUE; 3998 my $return_value; 3999 4000#------------------------------------------------------------------------------ 4001# Get the path name. 4002#------------------------------------------------------------------------------ 4003 my ($gp_file_name, $gp_path, $suffix_not_used) = fileparse ($full_command); 4004 4005 gp_message ("debug", $subr_name, "full_command = $full_command"); 4006 gp_message ("debug", $subr_name, "gp_path = $gp_path"); 4007 4008 my $gp_display_text_instance = $gp_path . $GP_DISPLAY_TEXT; 4009 4010#------------------------------------------------------------------------------ 4011# Check if $GP_DISPLAY_TEXT exists, is not empty, and executable. 4012#------------------------------------------------------------------------------ 4013 if (not -e $gp_display_text_instance) 4014 { 4015 $return_value = "file not found"; 4016 } 4017 else 4018 { 4019 if (is_file_empty ($gp_display_text_instance)) 4020 { 4021 $return_value = "file is empty"; 4022 } 4023 else 4024 { 4025#------------------------------------------------------------------------------ 4026# All is well. Capture the path. 4027#------------------------------------------------------------------------------ 4028 $error_occurred = $FALSE; 4029 $return_value = $gp_path; 4030 } 4031 } 4032 4033 return (\$error_occurred, \$return_value); 4034 4035} #-- End of subroutine find_path_to_gp_display_text 4036 4037#------------------------------------------------------------------------------ 4038# Scan the command line to see if the specified option is present. 4039# 4040# Two types of options are supported: options without a value (e.g. --help) or 4041# those that are set to "on" or "off". 4042# 4043# In this phase, we only need to check if a value is valid. If it is, we have 4044# to enable the corresponding global setting. If the value is not valid, we 4045# ignore it, since it will be caught later and a warning message is issued. 4046#------------------------------------------------------------------------------ 4047sub find_target_option 4048{ 4049 my $subr_name = get_my_name (); 4050 4051 my ($command_line_ref, $option_requires_value, $target_option) = @_; 4052 4053 my @command_line = @{ $command_line_ref }; 4054 my $option_value = undef; 4055 my $found_option = $FALSE; 4056 4057 my ($command_line_string) = join (" ", @command_line); 4058 4059## if ($command_line_string =~ /\s*($target_option)\s*(on|off)*\s*/) 4060#------------------------------------------------------------------------------ 4061# This does not make any assumptions on the values we are looking for. 4062#------------------------------------------------------------------------------ 4063 if ($command_line_string =~ /\s*\-\-($target_option)\s*(\w*)\s*/) 4064 { 4065 if (defined ($1)) 4066#------------------------------------------------------------------------------ 4067# We have found the option we are looking for. 4068#------------------------------------------------------------------------------ 4069 { 4070 $found_option = $TRUE; 4071 if ($option_requires_value and defined ($2)) 4072#------------------------------------------------------------------------------ 4073# There is a value and it is passed on to the caller. 4074#------------------------------------------------------------------------------ 4075 { 4076 $option_value = $2; 4077 } 4078 } 4079 } 4080 4081 return ($found_option, $option_value); 4082 4083} #-- End of subroutine find_target_option 4084 4085#------------------------------------------------------------------------------ 4086# Find the occurrences of non-space characters in a string and return their 4087# start and end index values(s). 4088#------------------------------------------------------------------------------ 4089sub find_words_in_line 4090{ 4091 my $subr_name = get_my_name (); 4092 4093 my ($input_line_ref) = @_; 4094 4095 my $input_line = ${ $input_line_ref }; 4096 4097 my $finished = $TRUE; 4098 4099 my $space = 0; 4100 my $space_position = 0; 4101 my $start_word; 4102 my $end_word; 4103 4104 my @word_delimiters = (); 4105 4106 gp_message ("debugXL", $subr_name, "input_line = $input_line"); 4107 4108 $finished = $FALSE; 4109 while (not $finished) 4110 { 4111 $space = index ($input_line, " ", $space_position); 4112 4113 my $txt = "string search space_position = $space_position "; 4114 $txt .= "space = $space"; 4115 gp_message ("debugXL", $subr_name, $txt); 4116 4117 if ($space != -1) 4118 { 4119 if ($space > $space_position) 4120 { 4121 $start_word = $space_position; 4122 $end_word = $space - 1; 4123 $space_position = $space; 4124 my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); 4125 gp_message ("debugXL", $subr_name, "string search start_word = $start_word end_word = $end_word space_position = $space_position $keyword"); 4126 push (@word_delimiters, [$start_word, $end_word]); 4127 } 4128 elsif ( ($space == $space_position) and ($space < length ($input_line) - 1)) 4129 { 4130 $space = $space + 1; 4131 $space_position = $space; 4132 } 4133 else 4134 { 4135 print "DONE\n"; 4136 $finished = $TRUE; 4137 gp_message ("debugXL", $subr_name, "completed - finished = $finished"); 4138 } 4139 } 4140 else 4141 { 4142 $finished = $TRUE; 4143 $start_word = $space_position; 4144 $end_word = length ($input_line) - 1; 4145 my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); 4146 push (@word_delimiters, [$start_word, $end_word]); 4147 if ($keyword =~ /\s+/) 4148 { 4149 my $txt = "end search spaces only"; 4150 gp_message ("debugXL", $subr_name, $txt); 4151 } 4152 else 4153 { 4154 my $txt = "end search start_word = $start_word "; 4155 $txt .= "end_word = $end_word "; 4156 $txt .= "space_position = $space_position -->$keyword<--"; 4157 gp_message ("debugXL", $subr_name, $txt); 4158 } 4159 } 4160 4161 } 4162 4163 for my $i (keys @word_delimiters) 4164 { 4165 gp_message ("debugXL", $subr_name, "i = $i $word_delimiters[$i][0] $word_delimiters[$i][1]"); 4166 } 4167 4168 return (\@word_delimiters); 4169 4170} #-- End of subroutine find_words_in_line 4171 4172#------------------------------------------------------------------------------ 4173# TBD 4174#------------------------------------------------------------------------------ 4175sub function_info 4176{ 4177 my $subr_name = get_my_name (); 4178 4179 my ($outputdir, $FUNC_FILE, $metric, $LINUX_vDSO_ref) = @_; 4180 4181 my %LINUX_vDSO = %{ $LINUX_vDSO_ref }; 4182 4183 my $index_val; 4184 my $address_decimal; 4185 my $full_address_field; 4186 4187 my $FUNC_FILE_NO_PC; 4188 my $off_with_the_PC; 4189 4190 my $blanks; 4191 my $lblanks; 4192 my $lvdso_key; 4193 my $line_regex; 4194 4195 my %functions_per_metric_indexes = (); 4196 my %functions_per_metric_first_index = (); 4197 my @order; 4198 4199 my ($line,$line_n,$value); 4200 my ($df_flag,$n,$u); 4201 my ($metric_value,$PC_Address,$routine); 4202 my ($is_calls,$metric_ok,$name_regex,$pc_len); 4203 my ($segment,$offset,$offy,$spaces,$rest,$not_printed,$vdso_key); 4204 4205#------------------------------------------------------------------------------ 4206# If the directory name does not end with a "/", add it. 4207#------------------------------------------------------------------------------ 4208 my $length_of_string = length ($outputdir); 4209 4210 if (rindex ($outputdir, "/") != $length_of_string-1) 4211 { 4212 $outputdir .= "/"; 4213 } 4214 4215 gp_message ("debug", $subr_name, "on input FUNC_FILE = $FUNC_FILE metric = $metric"); 4216 4217 $is_calls = $FALSE; 4218 $metric_ok = $TRUE; 4219 $off_with_the_PC = rindex ($FUNC_FILE, "-PC"); 4220 $FUNC_FILE_NO_PC = substr ($FUNC_FILE, 0, $off_with_the_PC); 4221 4222 if ($FUNC_FILE_NO_PC eq $outputdir."calls.sort.func") 4223 { 4224 $FUNC_FILE_NO_PC = $outputdir."calls"; 4225 $is_calls = $TRUE; 4226 $metric_ok = $FALSE; 4227 } 4228 elsif ($FUNC_FILE_NO_PC eq $outputdir."calltree.sort.func") 4229 { 4230 $FUNC_FILE_NO_PC = $outputdir."calltree"; 4231 $metric_ok = $FALSE; 4232 } 4233 elsif ($FUNC_FILE_NO_PC eq $outputdir."functions.sort.func") 4234 { 4235 $FUNC_FILE_NO_PC = $outputdir."functions.func"; 4236 $metric_ok = $FALSE; 4237 } 4238 gp_message ("debugM", $subr_name, "set FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC"); 4239 4240 open (FUNC_FILE, "<", $FUNC_FILE) 4241 or die ("Not able to open file $FUNC_FILE for reading - '$!'"); 4242 gp_message ("debug", $subr_name, "opened file FUNC_FILE = $FUNC_FILE for reading"); 4243 4244 open (FUNC_FILE_NO_PC, ">", $FUNC_FILE_NO_PC) 4245 or die ("Not able to open file $FUNC_FILE_NO_PC for writing - '$!'"); 4246 gp_message ("debug", $subr_name, "opened file FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC for writing"); 4247 4248 open (FUNC_FILE_REGEXP, "<", "$FUNC_FILE.name-regex") 4249 or die ("Not able to open file $FUNC_FILE.name-regex for reading - '$!'"); 4250 gp_message ("debug", $subr_name, "opened file FUNC_FILE_REGEXP = $FUNC_FILE.name-regex for reading"); 4251 4252 $name_regex = <FUNC_FILE_REGEXP>; 4253 chomp ($name_regex); 4254 close (FUNC_FILE_REGEXP); 4255 4256 gp_message ("debugXL", $subr_name, "name_regex = $name_regex"); 4257 4258 $n = 0; 4259 $u = 0; 4260 $pc_len = 0; 4261 4262#------------------------------------------------------------------------------ 4263# Note that the double \\ is needed here. The regex used will not have these. 4264#------------------------------------------------------------------------------ 4265 if ($is_calls) 4266 { 4267#------------------------------------------------------------------------------ 4268# TBD 4269# I do not see the "*" in my test output, but no harm to leave the code in. 4270# 4271# er_print * before PC for calls ! 101315 4272#------------------------------------------------------------------------------ 4273 $line_regex = "^(\\s*)(\\**)(\\S+)(:)(\\S+)(\\s+)(.*)"; 4274 } 4275 else 4276 { 4277 $line_regex = "^(\\s*)(\\S+)(:)(\\S+)(\\s+)(.*)"; 4278 } 4279 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." line_regex->$line_regex<-"); 4280 gp_message ("debugXL", $subr_name, "read FUNC_FILE = $FUNC_FILE"); 4281 4282 $line_n = 0; 4283 $index_val = 0; 4284 while (<FUNC_FILE>) 4285 { 4286 $line = $_; 4287 chomp ($line); 4288 4289# gp_message ("debug", $subr_name, "FUNC_FILE: input line = $line"); 4290 4291 $line_n++; 4292 if ($line =~ /$line_regex/) # field 2|3 needs to be \S in case of -ve sign 4293 { 4294#------------------------------------------------------------------------------ 4295# A typical target line looks like this: 4296# 11:0x001492e0 6976.900 <additional_timings> _lwp_start 4297#------------------------------------------------------------------------------ 4298 gp_message ("debugXL", $subr_name, "select = $line"); 4299 if ($is_calls) 4300 { 4301 $segment = $3; 4302 $offset = $5; 4303 $spaces = $6; 4304 $rest = $7; 4305 $PC_Address = $segment.$4.$offset; # PC Addr. 4306 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$3 = $3"); 4307 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); 4308 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); 4309 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$7 = $7"); 4310 } 4311 else 4312 { 4313 $segment = $2; 4314 $offset = $4; 4315 $spaces = $5; 4316 $rest = $6; 4317 $PC_Address = $segment.$3.$offset; # PC Addr. 4318 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$2 = $2"); 4319 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$4 = $4"); 4320 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); 4321 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); 4322 } 4323 if ($segment == -1) 4324 { 4325#------------------------------------------------------------------------------ 4326# presume vDSO field overflow - er_print used an inadequate format 4327# or the fsummary (MASTER) had the wrong format for -1? 4328# rats - get ahead of ourselves - should not be a field abuttal so 4329#------------------------------------------------------------------------------ 4330 if ($line =~ /$name_regex/) 4331 { 4332 if ($metric_ok) 4333 { 4334 $metric_value = $1; # whatever 4335 $routine = $2; 4336 } 4337 else 4338 { 4339 $routine = $1; 4340 } 4341 if ($is_calls) 4342 { 4343 if (substr ($routine,0,1) eq "*") 4344 { 4345 $routine = substr ($routine,1); 4346 } 4347 } 4348 for $vdso_key (keys %LINUX_vDSO) 4349 { 4350 if ($routine eq $LINUX_vDSO{$vdso_key}) 4351 { 4352#------------------------------------------------------------------------------ 4353# presume no duplicates - at least can check offset 4354#------------------------------------------------------------------------------ 4355 if ($vdso_key =~ /(\d+):(\S+)/) 4356#------------------------------------------------------------------------------ 4357# no -ve segments allowed and not expected 4358#------------------------------------------------------------------------------ 4359 { 4360 if ($2 eq $offset) 4361 { 4362#------------------------------------------------------------------------------ 4363# the real segment 4364#------------------------------------------------------------------------------ 4365 $segment = $1; 4366 gp_message ("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE"); 4367 $PC_Address = $segment.":".$offset; # PC Addr. 4368 gp_message ("debugXL", $subr_name, "vdso line ->$line"); 4369 $line = $PC_Address.(' ' x (length ($spaces)-2)).$rest; 4370 gp_message ("debugXL", $subr_name, "becomes ->$line"); 4371 last; 4372 } 4373 } 4374 } 4375 } 4376 } 4377 else 4378 { 4379 gp_message ("debug", $subr_name, "name_regex failure for file $FUNC_FILE"); 4380 } 4381 } 4382 4383#------------------------------------------------------------------------------ 4384# a rotten exception for Linux vDSO 4385# With a BIG "PC Address" like 32767:0x841fecd0, the functions.sort.func_PC file 4386# can have lines like 4387#->32767:0x841fecd0161.553 527182898954 131.936 100003 __vdso_gettimeofday<- 4388#->32767:0x153ff810 42.460 0 0 __vdso_gettimeofday<- 4389#->-1:0xff600000 99.040 0 0 [vsyscall]<- 4390# (Real PC Address: 4294967295:0xff600000) 4391#-> 4294967295:0xff600000 99.040 0 0 [vsyscall]<- 4392#-> 9:0x00000020 49.310 0 0 <static>@0x7fff153ff600 ([vdso])<- 4393# Rats! 4394# $LINUX_vDSO{substr($order[$i]{"addressobjtext"},1)} = $order[$i]{"routine"}; 4395#------------------------------------------------------------------------------ 4396 4397 $not_printed = $TRUE; 4398 for $vdso_key (keys %LINUX_vDSO) 4399 { 4400 if ($line =~ /^(\s*)($vdso_key)(.*)$/) 4401 { 4402 $blanks = 1; 4403 $rest = 3; 4404 $lblanks = length ($blanks); 4405 $lvdso_key = length ($vdso_key); 4406 $PC_Address = $vdso_key; # PC Addr. 4407 $offy = ($lblanks+$lvdso_key < $pc_len) ? $pc_len : $lblanks+$lvdso_key; 4408 gp_message ("debugXL", $subr_name, "offy = $offy for ->$line<-"); 4409 if ($pc_len) 4410 { 4411 print FUNC_FILE_NO_PC substr ($line,$offy)."\n"; 4412 $not_printed = $FALSE; 4413 } 4414 else 4415 { 4416 die ("sod1a"); 4417 } 4418 gp_message ("debugXL", $subr_name, "vdso line ->$line"); 4419 if (substr ($line,$lblanks+$lvdso_key,1) eq " ") 4420 { 4421#------------------------------------------------------------------------------ 4422# O.K. no field abuttal 4423#------------------------------------------------------------------------------ 4424 gp_message ("debugXL", $subr_name, "vdso no field abuttal line ->$line"); 4425 } 4426 else 4427 { 4428 gp_message ("debugXL", $subr_name, "vdso field abuttal line ->$line"); 4429 $line = $blanks.$vdso_key." ".$rest; 4430 } 4431 gp_message ("debugXL", $subr_name, "becomes ->$line"); 4432 last; 4433 } 4434 } 4435 if ($not_printed) 4436 { 4437 if ($pc_len) 4438 { 4439 print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; 4440 } 4441 else 4442 { 4443 die ("sod1b"); 4444 } 4445 $not_printed = $FALSE; 4446 } 4447 } 4448 else 4449 { 4450 if (!$pc_len) 4451 { 4452 if ($line =~ /(^\s*PC Addr.\s+)(\S+)/) 4453 { 4454 $pc_len = length ($1); # say 15 4455 print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; 4456 } 4457 else 4458 { 4459 print FUNC_FILE_NO_PC "$line\n"; 4460 } 4461 } 4462 else 4463 { 4464 if ($pc_len) 4465 { 4466 my $strlen = length ($line); 4467 if ($strlen > 0 ) 4468 { 4469 print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; 4470 } 4471 else 4472 { 4473 print FUNC_FILE_NO_PC "\n"; 4474 } 4475 } 4476 else 4477 { 4478 die ("sod2"); 4479 } 4480 } 4481 next; 4482 } 4483 $routine = ""; 4484 if ($line =~ /$name_regex/) 4485 { 4486 if ($metric_ok) 4487 { 4488 $metric_value = $1; # whatever 4489 $routine = $2; 4490 } 4491 else 4492 { 4493 $routine = $1; 4494 } 4495 } 4496 4497 if ($is_calls) 4498 { 4499 if (substr ($routine,0,1) eq "*") 4500 { 4501 $routine = substr ($routine,1); 4502 } 4503 } 4504 if (length ($routine)) 4505 { 4506 $order[$index_val]{"routine"} = $routine; 4507 if ($metric_ok) 4508 { 4509 $order[$index_val]{"metric_value"} = $metric_value; 4510 } 4511 $order[$index_val]{"PC Address"} = $PC_Address; 4512 $df_flag = 0; 4513 if (not exists ($functions_per_metric_indexes{$routine})) 4514 { 4515 $functions_per_metric_indexes{$routine} = [$index_val]; 4516 } 4517 else 4518 { 4519 push (@{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list 4520 } 4521 gp_message ("debugXL", $subr_name, "updated functions_per_metric_indexes $routine [$index_val] line = $line"); 4522 if ($PC_Address =~ /\s*(\S+):(\S+)/) 4523 { 4524 my ($segment,$offset); 4525 $segment = $1; 4526 $offset = $2; 4527 $address_decimal = bigint::hex ($offset); # decimal 4528 $full_address_field = '@'.$segment.":".$offset; # e.g. @2:0x0003f280 4529 $order[$index_val]{"addressobj"} = $address_decimal; 4530 $order[$index_val]{"addressobjtext"} = $full_address_field; 4531 } 4532#------------------------------------------------------------------------------ 4533# Check uniqueness 4534#------------------------------------------------------------------------------ 4535 if (not exists ($functions_per_metric_first_index{$routine}{$PC_Address})) 4536 { 4537 $functions_per_metric_first_index{$routine}{$PC_Address} = $index_val; 4538 $u++; #$RI 4539 } 4540 else 4541 { 4542 if (!($metric eq "calls" || $metric eq "calltree")) 4543 { 4544 gp_message ("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address"); 4545 } 4546 } 4547 4548 $index_val++; 4549 gp_message ("debugXL", $subr_name, "updated index_val = $index_val"); 4550 $n++; 4551 next; 4552 } 4553 else 4554 { 4555 if ($n && length ($line)) 4556 { 4557 my $msg = "unexpected line format in functions file $FUNC_FILE line->$line<-"; 4558 gp_message ("assertion", $subr_name, $msg); 4559 } 4560 } 4561 } 4562 close (FUNC_FILE); 4563 close (FUNC_FILE_NO_PC); 4564 4565 for my $i (sort keys %functions_per_metric_indexes) 4566 { 4567 my $values = ""; 4568 for my $fields (sort keys @{ $functions_per_metric_indexes{$i} }) 4569 { 4570 $values .= "$functions_per_metric_indexes{$i}[$fields] "; 4571 } 4572 gp_message ("debugXL", $subr_name, "on return: functions_per_metric_indexes{$i} = $values"); 4573 } 4574 4575 return (\@order, \%functions_per_metric_first_index, \%functions_per_metric_indexes); 4576 4577} #-- End of subroutine function_info 4578 4579#------------------------------------------------------------------------------ 4580# Generate a html header. 4581#------------------------------------------------------------------------------ 4582sub generate_a_header 4583{ 4584 my $subr_name = get_my_name (); 4585 4586 my ($page_text_ref, $size_text_ref, $position_text_ref) = @_; 4587 4588 my $page_text = ${ $page_text_ref }; 4589 my $size_text = ${ $size_text_ref }; 4590 my $position_text = ${ $position_text_ref }; 4591 my $html_header; 4592 4593 $html_header = "<div class=\"" . $position_text . "\">\n"; 4594 $html_header .= "<". $size_text . ">\n"; 4595 $html_header .= $page_text . "\n"; 4596 $html_header .= "</". $size_text . ">\n"; 4597 $html_header .= "</div>"; 4598 4599 gp_message ("debugXL", $subr_name, "on exit page_title = $html_header"); 4600 4601 return (\$html_header); 4602 4603} #-- End of subroutine generate_a_header 4604 4605#------------------------------------------------------------------------------ 4606# Generate the caller-callee information. 4607#------------------------------------------------------------------------------ 4608sub generate_caller_callee 4609{ 4610 my $subr_name = get_my_name (); 4611 4612 my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref, 4613 $function_address_info_ref, $addressobjtextm_ref, 4614 $input_string_ref) = @_; 4615 4616 my $number_of_metrics = ${ $number_of_metrics_ref }; 4617 my @function_info = @{ $function_info_ref }; 4618 my %function_view_structure = %{ $function_view_structure_ref }; 4619 my %function_address_info = %{ $function_address_info_ref }; 4620 my %addressobjtextm = %{ $addressobjtextm_ref }; 4621 my $input_string = ${ $input_string_ref }; 4622 4623 my @caller_callee_data = (); 4624 my $outfile; 4625 my $input_line; 4626 4627 my $fullname; 4628 my $separator = "cuthere"; 4629 4630 my @address_field = (); 4631 my @fields = (); 4632 my @function_names = (); 4633 my @marker = (); 4634 my @metric_values = (); 4635 my @word_index_values = (); 4636 my @header_lines = (); 4637 4638 my $all_metrics; 4639 my $elements_in_name; 4640 my $full_hex_address; 4641 my $hex_address; 4642 4643 my $file_title; 4644 my $page_title; 4645 my $size_text; 4646 my $position_text; 4647 my @html_metric_sort_header = (); 4648 my $html_header; 4649 my $html_title_header; 4650 my $html_home; 4651 my $html_acknowledgement; 4652 my $html_end; 4653 my $html_line; 4654 4655 my $marker_target_function; 4656 my $max_metrics_length = 0; 4657 my $metrics_length; 4658 my $modified_line; 4659 my $name_regex; 4660 my $no_of_fields; 4661 my $routine; 4662 my $routine_length; 4663 my $string_length; 4664 my $top_header; 4665 my $total_header_lines; 4666 my $word_index_values_ref; 4667 my $infile; 4668 4669 my $outputdir = append_forward_slash ($input_string); 4670 my $LANG = $g_locale_settings{"LANG"}; 4671 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 4672 4673 gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator"); 4674 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 4675 4676 $infile = $outputdir . "caller-callee-PC2"; 4677 $outfile = $outputdir . $g_html_base_file_name{"caller_callee"} . ".html"; 4678 4679 gp_message ("debug", $subr_name, "infile = $infile outfile = $outfile"); 4680 4681 open (CALLER_CALLEE_IN, "<", $infile) 4682 or die ("unable to open caller file $infile for reading - '$!'"); 4683 gp_message ("debug", $subr_name, "opened file $infile for reading"); 4684 4685 open (CALLER_CALLEE_OUT, ">", $outfile) 4686 or die ("unable to open $outfile for writing - '$!'"); 4687 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 4688 4689 gp_message ("debug", $subr_name, "building caller-callee file $outfile"); 4690 4691#------------------------------------------------------------------------------ 4692# Generate some of the structures used in the HTML output. 4693#------------------------------------------------------------------------------ 4694 $file_title = "Caller-callee overview"; 4695 $html_header = ${ create_html_header (\$file_title) }; 4696 $html_home = ${ generate_home_link ("right") }; 4697 4698 $page_title = "Caller Callee View"; 4699 $size_text = "h2"; 4700 $position_text = "center"; 4701 $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 4702 4703#------------------------------------------------------------------------------ 4704# Read all of the file into array with the name caller_callee_data. 4705#------------------------------------------------------------------------------ 4706 chomp (@caller_callee_data = <CALLER_CALLEE_IN>); 4707 4708#------------------------------------------------------------------------------ 4709# Typical structure of the input file: 4710# 4711# Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm 4712# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 4713# Functions sorted by metric: Exclusive Total CPU Time 4714# Callers and callees sorted by metric: Attributed Total CPU Time 4715# 4716# PC Addr. Name Attr. Attr. CPU Attr. Attr. 4717# Total Cycles Instructions Last-Level 4718# CPU sec. sec. Executed Cache Misses 4719# 1:0x00000000 *<Total> 3.502 4.005 15396819700 24024250 4720# 7:0x00008070 start_thread 3.342 3.865 14500538981 23824045 4721# 6:0x000233a0 __libc_start_main 0.160 0.140 896280719 200205 4722# 4723# PC Addr. Name Attr. Attr. CPU Attr. Attr. 4724# Total Cycles Instructions Last-Level 4725# CPU sec. sec. Executed Cache Misses 4726# 2:0x000021f9 driver_mxv 3.342 3.865 14500538981 23824045 4727# 2:0x000021ae *mxv_core 3.342 3.865 14500538981 23824045 4728#------------------------------------------------------------------------------ 4729 4730#------------------------------------------------------------------------------ 4731# Scan the input file. The first lines are assumed to be part of the header, 4732# so we store those. The diagnostic lines that echo some settings are also 4733# stored, but currently not used. 4734#------------------------------------------------------------------------------ 4735 my $scan_header = $FALSE; 4736 my $scan_caller_callee_data = $FALSE; 4737 my $data_function_block = ""; 4738 my @function_blocks = (); 4739 my $first = $TRUE; 4740 my @html_caller_callee = (); 4741 my @top_level_header = (); 4742 4743#------------------------------------------------------------------------------ 4744# The regexes. 4745#------------------------------------------------------------------------------ 4746 my $empty_line_regex = '^\s*$'; 4747 my $line_of_interest_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\**)(.*)'; 4748 my $get_hex_address_regex = '(\d+):0x(\S+)'; 4749 my $get_metric_field_regex = ')\s+([\s\d' . $decimal_separator . ']*)'; 4750 my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)'; 4751 my $sorted_by_regex = 'sorted by metric:'; 4752 my $current_regex = '^Current'; 4753 my $get_addr_offset_regex = '^@\d+:'; 4754 4755#------------------------------------------------------------------------------ 4756# Get the length of the first metric field across all lines. This value is 4757# used to pad the first metric with spaces and get the alignment right. 4758# 4759# Scan the input data and find the line(s) with metric values. A complication 4760# is that a function name may consists of more than one field. 4761# 4762# Note. This part could be used to parse the other elements of the input file, 4763# but that makes the loop very complicated. Instead, we re-scan the data 4764# below and process each block separately. 4765# 4766# Since this data is all in memory and relatively small, the performance should 4767# not suffer much, but it does improve the readability of the code. 4768#------------------------------------------------------------------------------ 4769 gp_message ("debug", $subr_name, "determine the maximum length of the first field"); 4770 4771 $g_max_length_first_metric = 0; 4772 my @hex_addresses = (); 4773 my @special_marker = (); 4774 my @the_function_name = (); 4775 my @the_metrics = (); 4776 my @length_first_metric = (); 4777 4778 for (my $line = 0; $line <= $#caller_callee_data; $line++) 4779 { 4780 my $input_line = $caller_callee_data[$line]; 4781 4782 if ($input_line =~ /$line_of_interest_regex/) 4783 { 4784 if (defined ($1) and defined ($2) and defined ($3)) 4785#------------------------------------------------------------------------------ 4786# This is a line of interest, since it has the address, the function name and 4787# the values for the metrics. Examples of valid lines are: 4788# 4789# 2:0x00005028 *xfree_large 0. 0 4790# 12:0x0004c2b0 munmap 0.143 6402086 4791# 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0 4792# 4793# The function name marked with a * is the current target. 4794#------------------------------------------------------------------------------ 4795 { 4796 my $full_hex_address = $1; 4797 my $marker = $2; 4798 my $remaining_line = $3; 4799 4800 if ($full_hex_address =~ /$get_hex_address_regex/) 4801 { 4802 $hex_address = "0x" . $2; 4803 push (@hex_addresses, $hex_address); 4804 gp_message ("debugXL", $subr_name, "pushed $hex_address"); 4805 } 4806 else 4807 { 4808 my $msg = "full_hex_address = $full_hex_address has an unknown format"; 4809 gp_message ("assertion", $subr_name, $msg); 4810 } 4811 if ($marker eq "*") 4812 { 4813 push (@special_marker, "*"); 4814 } 4815 else 4816 { 4817 push (@special_marker, "X"); 4818 } 4819 } 4820 else 4821 { 4822 my $msg = "input_line = $input_line has an unknown format"; 4823 gp_message ("assertion", $subr_name, $msg); 4824 } 4825 4826 my @fields_in_line = split (" ", $input_line); 4827 4828#------------------------------------------------------------------------------ 4829# We stripped the address and marker (if any), off, so this string starts with 4830# the function name. 4831#------------------------------------------------------------------------------ 4832 my $remainder = $3; 4833 my $number_of_fields = scalar (@fields_in_line); 4834 my $words_in_function_name = $number_of_fields - $number_of_metrics - 1; 4835 my @remainder_array = split (" ", $remainder); 4836 4837#------------------------------------------------------------------------------ 4838# If the first metric is 0. (or 0, depending on the locale), the calculation 4839# of the length needs to be adjusted, because 0. is really 0.000. 4840# 4841# While we could easily add 3 to the length, we assign a symbolic value to the 4842# first metric (ZZZ) and then compute the length. This makes things clearer. 4843# I hope ;-) 4844#------------------------------------------------------------------------------ 4845 my $first_metric = $remainder_array[$words_in_function_name]; 4846 if ($first_metric =~ /^0$decimal_separator$/) 4847 { 4848 gp_message ("debugXL", $subr_name, "fixed up $first_metric"); 4849 $first_metric = "0.ZZZ"; 4850 } 4851 push (@length_first_metric, length ($first_metric)); 4852 4853 my $txt = "words in function name = $words_in_function_name "; 4854 $txt .= "first_metric = $first_metric length = "; 4855 $txt .= length ($first_metric); 4856 gp_message ("debugXL", $subr_name, $txt); 4857 4858#------------------------------------------------------------------------------ 4859# Generate the regex for the metrics. 4860# 4861# TBD: This should be an attribute of the function and be done once only. 4862#------------------------------------------------------------------------------ 4863 my $m_regex = '(\S+'; 4864 for my $f (2 .. $words_in_function_name) 4865 { 4866 $m_regex .= '\s+\S+'; 4867 } 4868#------------------------------------------------------------------------------ 4869# This last part captures all the metric values. 4870#------------------------------------------------------------------------------ 4871 $m_regex .= $get_metric_field_regex; 4872 gp_message ("debugXL", $subr_name, "m_regex = $m_regex"); 4873 gp_message ("debugXL", $subr_name, "remainder = $remainder"); 4874 4875 if ($remainder =~ /$m_regex/) 4876 { 4877 my $func_name = $1; 4878 my $its_metrics = $2; 4879 my $msg = "found the info - func_name = " . $func_name . 4880 " its metrics = " . $its_metrics; 4881 gp_message ("debugXL", $subr_name, $msg); 4882 4883 push (@the_function_name, $func_name); 4884 push (@the_metrics, $its_metrics); 4885 } 4886 else 4887 { 4888 my $msg = "remainder string $remainder has an unrecognized format"; 4889 gp_message ("assertion", $subr_name, $msg); 4890 } 4891 4892 $g_max_length_first_metric = max ($g_max_length_first_metric, length ($first_metric)); 4893 4894 my $msg = "first_metric = $first_metric " . 4895 "g_max_length_first_metric = $g_max_length_first_metric"; 4896 gp_message ("debugXL", $subr_name, $msg); 4897 } 4898 } 4899 gp_message ("debugXL", $subr_name, "final: g_max_length_first_metric = $g_max_length_first_metric"); 4900 gp_message ("debugXL", $subr_name, "#hex_addresses = $#hex_addresses"); 4901 4902#------------------------------------------------------------------------------ 4903# Main loop over the input data. 4904#------------------------------------------------------------------------------ 4905 my $index_start = 0; # 1 4906 my $index_end = -1; # 0 4907 for (my $line = 0; $line <= $#caller_callee_data; $line++) 4908 { 4909 my $input_line = $caller_callee_data[$line]; 4910 4911 if ($input_line =~ /$header_name_regex/) 4912 { 4913 $scan_header = $TRUE; 4914 gp_message ("debugXL", $subr_name, "line = $line encountered start of the header scan_header = $scan_header first = $first"); 4915 } 4916 elsif (($input_line =~ /$sorted_by_regex/) or ($input_line =~ /$current_regex/)) 4917 { 4918 my $msg = "line = " . $line . " captured top level header: " . 4919 "input_line = " . $input_line; 4920 gp_message ("debugXL", $subr_name, $msg); 4921 4922 push (@top_level_header, $input_line); 4923 } 4924 elsif ($input_line =~ /$line_of_interest_regex/) 4925 { 4926 $index_end++; 4927 $scan_header = $FALSE; 4928 $scan_caller_callee_data = $TRUE; 4929 $data_function_block .= $separator . $input_line; 4930 4931 my $msg = "line = $line updated index_end = $index_end"; 4932 gp_message ("debugXL", $subr_name, $msg); 4933 } 4934 elsif (($input_line =~ /$empty_line_regex/) and ($scan_caller_callee_data)) 4935 { 4936#------------------------------------------------------------------------------ 4937# An empty line is interpreted as the end of the current block and we process 4938# this, including the generation of the html code for this block. 4939#------------------------------------------------------------------------------ 4940 $first = $FALSE; 4941 $scan_caller_callee_data = $FALSE; 4942 4943 gp_message ("debugXL", $subr_name, "new block"); 4944 gp_message ("debugXL", $subr_name, "line = $line index_start = $index_start"); 4945 gp_message ("debugXL", $subr_name, "line = $line index_end = $index_end"); 4946 gp_message ("debugXL", $subr_name, "line = $line data_function_block = $data_function_block"); 4947 4948 push (@function_blocks, $data_function_block); 4949 my ($html_block_prologue_ref, $html_code_function_block_ref) = 4950 generate_html_function_blocks ( 4951 \$index_start, 4952 \$index_end, 4953 \@hex_addresses, 4954 \@the_metrics, 4955 \@length_first_metric, 4956 \@special_marker, 4957 \@the_function_name, 4958 \$separator, 4959 $number_of_metrics_ref, 4960 \$data_function_block, 4961 $function_info_ref, 4962 $function_view_structure_ref); 4963 4964 my @html_block_prologue = @{ $html_block_prologue_ref }; 4965 my @html_code_function_block = @{ $html_code_function_block_ref }; 4966 4967 for my $lines (0 .. $#html_code_function_block) 4968 { 4969 my $msg = "final html_code_function_block[" . $lines . "] = " . 4970 $html_code_function_block[$lines]; 4971 gp_message ("debugXL", $subr_name, $msg); 4972 } 4973 4974 $data_function_block = ""; 4975 4976 push (@html_caller_callee, @html_block_prologue); 4977 push (@html_caller_callee, @header_lines); 4978 push (@html_caller_callee, @html_code_function_block); 4979 4980 $index_start = $index_end + 1; 4981 $index_end = $index_start - 1; 4982 gp_message ("debugXL", $subr_name, "line = $line reset index_start = $index_start"); 4983 gp_message ("debugXL", $subr_name, "line = $line reset index_end = $index_end"); 4984 } 4985 4986#------------------------------------------------------------------------------ 4987# Only capture the first header. They are all identical. 4988#------------------------------------------------------------------------------ 4989 if ($scan_header and $first) 4990 { 4991 if (defined ($4)) 4992 { 4993#------------------------------------------------------------------------------ 4994# This group is only defined for the first line of the header. 4995#------------------------------------------------------------------------------ 4996 gp_message ("debugXL", $subr_name, "header1 = $4"); 4997 gp_message ("debugXL", $subr_name, "extra = $3 spaces=x$2x"); 4998 my $newline = "<b>" . $4 . "</b>"; 4999 push (@header_lines, $newline); 5000 } 5001 elsif ($input_line =~ /\s*(.*)/) 5002 { 5003#------------------------------------------------------------------------------ 5004# Capture the subsequent header lines. 5005#------------------------------------------------------------------------------ 5006 gp_message ("debugXL", $subr_name, "headern = $1"); 5007 my $newline = "<b>" . $1 . "</b>"; 5008 push (@header_lines, $newline); 5009 } 5010 } 5011 5012 } 5013 5014 for my $i (0 .. $#header_lines) 5015 { 5016 gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]"); 5017 } 5018 for my $i (0 .. $#function_blocks) 5019 { 5020 gp_message ("debugXL", $subr_name, "function_blocks[$i] = $function_blocks[$i]"); 5021 } 5022 5023 my $number_of_blocks = $#function_blocks + 1; 5024 gp_message ("debugXL", $subr_name, "There are " . $number_of_blocks . " function blocks:"); 5025 5026 for my $i (0 .. $#function_blocks) 5027 { 5028#------------------------------------------------------------------------------ 5029# The split produces an empty first field and is why we skip the first field. 5030#------------------------------------------------------------------------------ 5031## my @entries = split ("cuthere", $function_blocks[$i]); 5032 my @entries = split ($separator, $function_blocks[$i]); 5033 for my $k (1 .. $#entries) 5034 { 5035 my $msg = "entries[" . $k . "] = ". $entries[$k]; 5036 gp_message ("debugXL", $subr_name, $k . $msg); 5037 } 5038 } 5039 5040#------------------------------------------------------------------------------ 5041# Parse and process the individual function blocks. 5042#------------------------------------------------------------------------------ 5043 for my $i (0 .. $#function_blocks) 5044 { 5045 my $msg = "function_blocks[" . $i . "] = ". $function_blocks[$i]; 5046 gp_message ("debugXL", $subr_name, $msg); 5047#------------------------------------------------------------------------------ 5048# This split produces an empty first field. This is why skip this. 5049#------------------------------------------------------------------------------ 5050 my @entries = split ($separator, $function_blocks[$i]); 5051 5052#------------------------------------------------------------------------------ 5053# An example of @entries: 5054# <empty> 5055# 6:0x0003ad20 drand48 0.100 0.084 768240570 0 5056# 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0 5057# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 5058#------------------------------------------------------------------------------ 5059 for my $k (1 .. $#entries) 5060 { 5061 my $input_line = $entries[$k]; 5062 5063 my $msg = "input_line = entries[" . $k . "] = ". $entries[$k]; 5064 gp_message ("debugXL", $subr_name, $msg); 5065 5066 @fields = split (" ", $input_line); 5067 5068 $no_of_fields = $#fields + 1; 5069 $elements_in_name = $no_of_fields - $number_of_metrics - 1; 5070 5071#------------------------------------------------------------------------------ 5072# TBD: Too restrictive. 5073# CHECK CODE IN GENERATE_CALLER_CALLEE 5074#------------------------------------------------------------------------------ 5075 if ($elements_in_name == 1) 5076 { 5077 $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])(\S+)\s+(.*)'; 5078 } 5079 elsif ($elements_in_name == 2) 5080 { 5081 $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])((\S+)\s+(\S+))\s+(.*)'; 5082 } 5083 else 5084#------------------------------------------------------------------------------ 5085# TBD: Handle this better in case a function entry has more than 2 words. 5086#------------------------------------------------------------------------------ 5087 { 5088 my $msg = "$elements_in_name elements in name exceeds limit"; 5089 gp_message ("assertion", $subr_name, $msg); 5090 } 5091 5092 if ($input_line =~ /$name_regex/) 5093 { 5094 $full_hex_address = $1; 5095 $marker_target_function = $2; 5096 $routine = $3; 5097 if ($elements_in_name == 1) 5098 { 5099 $all_metrics = $4; 5100 } 5101 elsif ($elements_in_name == 2) 5102 { 5103 $all_metrics = $6; 5104 } 5105 5106 $metrics_length = length ($all_metrics); 5107 $max_metrics_length = max ($max_metrics_length, $metrics_length); 5108 5109 if ($full_hex_address =~ /(\d+):0x(\S+)/) 5110 { 5111 $hex_address = "0x" . $2; 5112 } 5113 push (@marker, $marker_target_function); 5114 push (@address_field, $hex_address); 5115 $modified_line = $all_metrics . " " . $routine; 5116 push (@metric_values, $all_metrics); 5117 gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line"); 5118 push (@function_names, $routine); 5119 } 5120 } 5121 5122 $total_header_lines = $#header_lines + 1; 5123 gp_message ("debugXL", $subr_name, "total_header_lines = $total_header_lines"); 5124 5125 gp_message ("debugXL", $subr_name, "Final output"); 5126 for my $i (keys @header_lines) 5127 { 5128 gp_message ("debugXL", $subr_name, "$header_lines[$i]"); 5129 } 5130 for my $i (0 .. $#function_names) 5131 { 5132 my $msg = $metric_values[$i] . " " . $marker[$i] . 5133 $function_names[$i] . "(" . $address_field[$i] . ")"; 5134 gp_message ("debugXL", $subr_name, $msg); 5135 } 5136#------------------------------------------------------------------------------ 5137# Check if this function has multiple occurrences. 5138# TBD: Replace by the function call for this. 5139#------------------------------------------------------------------------------ 5140 gp_message ("debugXL", $subr_name, "check for multiple occurrences"); 5141 for my $i (0 .. $#function_names) 5142 { 5143 my $current_address = $address_field[$i]; 5144 my $found_a_match; 5145 my $ref_index; 5146 my $alt_name; 5147 $routine = $function_names[$i]; 5148 $alt_name = $routine; 5149 gp_message ("debugXL", $subr_name, "checking for routine = $routine"); 5150 if (exists ($g_multi_count_function{$routine})) 5151 { 5152 5153#------------------------------------------------------------------------------ 5154# TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!! 5155#------------------------------------------------------------------------------ 5156 5157 $found_a_match = $FALSE; 5158 gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); 5159 for my $ref (keys @{ $g_map_function_to_index{$routine} }) 5160 { 5161 $ref_index = $g_map_function_to_index{$routine}[$ref]; 5162 5163 gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); 5164 gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); 5165 5166 my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; 5167 gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); 5168 5169 $addr_offset =~ s/$get_addr_offset_regex//; 5170 gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); 5171 if ($addr_offset eq $current_address) 5172 { 5173 $found_a_match = $TRUE; 5174 last; 5175 } 5176 } 5177 gp_message ("debugXL", $subr_name, "$function_info[$ref_index]{'alt_name'} is the actual function for i = $i $found_a_match"); 5178 $alt_name = $function_info[$ref_index]{'alt_name'}; 5179 } 5180 gp_message ("debugXL", $subr_name, "alt_name = $alt_name"); 5181 } 5182 gp_message ("debugXL", $subr_name, "completed check for multiple occurrences"); 5183 5184#------------------------------------------------------------------------------ 5185# Figure out the column width. Since the columns in the header may include 5186# spaces, we use the first line with metrics for this. 5187#------------------------------------------------------------------------------ 5188 my $top_header = $metric_values[0]; 5189 my $word_index_values_ref = find_words_in_line (\$top_header); 5190 my @word_index_values = @{ $word_index_values_ref }; 5191 5192# $i = 0 0 4 5193# $i = 1 10 14 5194# $i = 2 21 31 5195# $i = 3 35 42 5196 for my $i (keys @word_index_values) 5197 { 5198 gp_message ("debugXL", $subr_name, "i = $i $word_index_values[$i][0] $word_index_values[$i][1]"); 5199 } 5200 } 5201 5202 push (@html_metric_sort_header, "<i>"); 5203 for my $i (0 .. $#top_level_header) 5204 { 5205 $html_line = $top_level_header[$i] . "<br>"; 5206 push (@html_metric_sort_header, $html_line); 5207 } 5208 push (@html_metric_sort_header, "</i>"); 5209 5210 print CALLER_CALLEE_OUT $html_header; 5211 print CALLER_CALLEE_OUT $html_home; 5212 print CALLER_CALLEE_OUT $html_title_header; 5213 print CALLER_CALLEE_OUT "$_" for @g_html_experiment_stats; 5214## print CALLER_CALLEE_OUT "<br>\n"; 5215## print CALLER_CALLEE_OUT "$_\n" for @html_metric_sort_header; 5216 print CALLER_CALLEE_OUT "<pre>\n"; 5217 print CALLER_CALLEE_OUT "$_\n" for @html_caller_callee; 5218 print CALLER_CALLEE_OUT "</pre>\n"; 5219 5220#------------------------------------------------------------------------------- 5221# Get the acknowledgement, return to main link, and final html statements. 5222#------------------------------------------------------------------------------- 5223 $html_home = ${ generate_home_link ("left") }; 5224 $html_acknowledgement = ${ create_html_credits () }; 5225 $html_end = ${ terminate_html_document () }; 5226 5227 print CALLER_CALLEE_OUT $html_home; 5228 print CALLER_CALLEE_OUT "<br>\n"; 5229 print CALLER_CALLEE_OUT $html_acknowledgement; 5230 print CALLER_CALLEE_OUT $html_end; 5231 5232 close (CALLER_CALLEE_OUT); 5233 5234 return (0); 5235 5236} #-- End of subroutine generate_caller_callee 5237 5238#------------------------------------------------------------------------------ 5239# Generate the html version of the disassembly file. 5240# 5241# Note to self (TBD) 5242# https://software.intel.com/content/www/us/en/develop/blogs/intel-release-new-technology-specifications-protect-rop-attacks.html 5243#------------------------------------------------------------------------------ 5244sub generate_dis_html 5245{ 5246 my $subr_name = get_my_name (); 5247 5248 my ($target_function_ref, $number_of_metrics_ref, $function_info_ref, 5249 $function_address_and_index_ref, $outputdir_ref, $func_ref, 5250 $source_line_ref, $metric_ref, $addressobj_index_ref) = @_; 5251 5252 my $target_function = ${ $target_function_ref }; 5253 my $number_of_metrics = ${ $number_of_metrics_ref }; 5254 my @function_info = @{ $function_info_ref }; 5255 my %function_address_and_index = %{ $function_address_and_index_ref }; 5256 my $outputdir = ${ $outputdir_ref }; 5257 my $func = ${ $func_ref }; 5258 my @source_line = @{ $source_line_ref }; 5259 my @metric = @{ $metric_ref }; 5260 my %addressobj_index = %{ $addressobj_index_ref }; 5261 5262 my $dec_instruction_start; 5263 my $dec_instruction_end; 5264 my $hex_instruction_start; 5265 my $hex_instruction_end; 5266 5267 my @colour_line = (); 5268 my $hot_line; 5269 my $metric_values; 5270 my $src_line; 5271 my $dec_instr_address; 5272 my $instruction; 5273 my $operands; 5274 5275 my $html_new_line = "<br>"; 5276 my $add_new_line_before; 5277 my $add_new_line_after; 5278 my $address_key; 5279 my $boldface; 5280 my $file; 5281 my $filename = $func; 5282 my $func_name; 5283 my $orig_hex_instr_address; 5284 my $hex_instr_address; 5285 my $index_string; 5286 my $input_metric; 5287 my $linenumber; 5288 my $name; 5289 my $last_address; 5290 my $last_address_in_hex; 5291 5292 my $file_title; 5293 my $html_header; 5294 my $html_home; 5295 my $html_end; 5296 5297 my $branch_regex = $g_arch_specific_settings{"regex"}; 5298 my $convert_to_dot = $g_locale_settings{"convert_to_dot"}; 5299 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 5300 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; 5301 my $linksubexp = $g_arch_specific_settings{"linksubexp"}; 5302 my $subexp = $g_arch_specific_settings{"subexp"}; 5303 5304 my $is_empty; 5305 5306 my %branch_target = (); 5307 my %branch_target_no_ref = (); 5308 my @disassembly_file = (); 5309 my %extended_branch_target = (); 5310 my %inverse_branch_target = (); 5311 my @metrics = (); 5312 my @modified_html = (); 5313 5314 my $branch_target_ref; 5315 my $extended_branch_target_ref; 5316 my $branch_target_no_ref_ref; 5317 5318 my $branch_address; 5319 my $dec_branch_address; 5320 my $found_it; 5321 my $found_it_ref; 5322 my $func_name_in_dis_file; 5323 my $hex_branch_target; 5324 my $instruction_address; 5325 my $instruction_offset; 5326 my $link; 5327 my $modified_line; 5328 my $raw_hex_branch_target; 5329 my $src_line_ref; 5330 my $threshold_line; 5331 my $html_dis_out = $func . ".html"; 5332 5333#------------------------------------------------------------------------------ 5334# The regex section. 5335#------------------------------------------------------------------------------ 5336 my $call_regex = '.*([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)'; 5337 my $line_of_interest_regex = '^#*\s+([\d' . $decimal_separator . '\s+]+)\[\s*(\d+|\?)\]'; 5338 my $white_space_regex = '\s+'; 5339 my $first_integer_regex = '^\d+$'; 5340 my $integer_regex = '\d+'; 5341 my $qmark_regex = '\?'; 5342 my $src_regex = '(\s*)(\d+)\.(.*)'; 5343 my $function_regex = '^(\s*)<Function:\s(.*)>'; 5344 my $end_src_header_regex = "(^\\s+)(\\d+)\\.\\s+(.*)"; 5345 my $end_dis_header_regex = "(^\\s+)(<Function: )(.*)>"; 5346 my $control_flow_1_regex = 'j[a-z]+'; 5347 my $control_flow_2_regex = 'call'; 5348 my $control_flow_3_regex = 'ret'; 5349 5350## my $function_call_regex2 = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; 5351## my $endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; 5352#------------------------------------------------------------------------------ 5353# Dynamic. Computed below. 5354# 5355# TBD: Try to move these up. 5356#------------------------------------------------------------------------------ 5357 my $dis_regex; 5358 my $metric_regex; 5359 5360 gp_message ("debug", $subr_name, "g_branch_regex = $g_branch_regex"); 5361 gp_message ("debug", $subr_name, "call_regex = $call_regex"); 5362 gp_message ("debug", $subr_name, "g_function_call_v2_regex = $g_function_call_v2_regex"); 5363 5364 my $the_title = set_title ($function_info_ref, $func, "disassembly"); 5365 5366 gp_message ("debug", $subr_name, "the_title = $the_title"); 5367 5368 $file_title = $the_title; 5369 $html_header = ${ create_html_header (\$file_title) }; 5370 $html_home = ${ generate_home_link ("right") }; 5371 5372 push (@modified_html, $html_header); 5373 push (@modified_html, $html_home); 5374 push (@modified_html, "<pre>"); 5375 5376#------------------------------------------------------------------------------ 5377# Open the input and output files. 5378#------------------------------------------------------------------------------ 5379 open (INPUT_DISASSEMBLY, "<", $filename) 5380 or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'"); 5381 gp_message ("debug", $subr_name , "opened file $filename for reading"); 5382 5383 open (HTML_OUTPUT, ">", $html_dis_out) 5384 or die ("$subr_name - unable to open file $html_dis_out for writing: '$!'"); 5385 gp_message ("debug", $subr_name , "opened file $html_dis_out for writing"); 5386 5387#------------------------------------------------------------------------------ 5388# Check if the file is empty 5389#------------------------------------------------------------------------------ 5390 $is_empty = is_file_empty ($filename); 5391 if ($is_empty) 5392 { 5393 5394#------------------------------------------------------------------------------ 5395# The input file is empty. Write a message in the html file and exit. 5396#------------------------------------------------------------------------------ 5397 gp_message ("debug", $subr_name ,"file $filename is empty"); 5398 5399 my $comment = "No disassembly generated by $tool_name - file $filename is empty"; 5400 my $gp_error_file = $outputdir . "gp-listings.err"; 5401 5402 my $html_empty_file_ref = html_text_empty_file (\$comment, \$gp_error_file); 5403 my @html_empty_file = @{ $html_empty_file_ref }; 5404 5405 print HTML_OUTPUT "$_\n" for @html_empty_file; 5406 5407 close (HTML_OUTPUT); 5408 5409 return (\@source_line); 5410 } 5411 else 5412 { 5413 5414#------------------------------------------------------------------------------ 5415# Read the file into memory. 5416#------------------------------------------------------------------------------ 5417 chomp (@disassembly_file = <INPUT_DISASSEMBLY>); 5418 gp_message ("debug", $subr_name ,"read file $filename into memory"); 5419 } 5420 5421 my $max_length_first_metric = 0; 5422 my $src_line_no; 5423 5424#------------------------------------------------------------------------------ 5425# First scan through the assembly listing. 5426#------------------------------------------------------------------------------ 5427 for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++) 5428 { 5429 my $input_line = $disassembly_file[$line_no]; 5430 gp_message ("debugXL", $subr_name, "[line $line_no] $input_line"); 5431 5432 if ($input_line =~ /$line_of_interest_regex/) 5433 { 5434 5435#------------------------------------------------------------------------------ 5436# Found a matching line. Examples are: 5437# 0.370 [37] 4021d1: addsd %xmm0,%xmm1 5438# ## 1.001 [36] 4021d5: add $0x1,%rax 5439#------------------------------------------------------------------------------ 5440 gp_message ("debugXL", $subr_name, "selected line \$1 = $1 \$2 = $2"); 5441 5442 if (defined ($2) and defined($1)) 5443 { 5444 @metrics = split (/$white_space_regex/ ,$1); 5445 $src_line_no = $2; 5446 } 5447 else 5448 { 5449 my $msg = "$input_line has an unexpected format"; 5450 gp_message ("assertion", $subr_name, $msg); 5451 } 5452 5453#------------------------------------------------------------------------------ 5454# Compute the maximum length of the first metric and pad the field from the 5455# left later on. The fractional part is ignored. 5456#------------------------------------------------------------------------------ 5457 my $first_metric = $metrics[0]; 5458 my $new_length; 5459 if ($first_metric =~ /$first_integer_regex/) 5460 { 5461 $new_length = length ($first_metric); 5462 } 5463 else 5464 { 5465 my @fields = split (/$decimal_separator/, $first_metric); 5466 $new_length = length ($fields[0]); 5467 } 5468 $max_length_first_metric = max ($max_length_first_metric, $new_length); 5469 my $msg; 5470 $msg = "first_metric = $first_metric " . 5471 "max_length_first_metric = $max_length_first_metric"; 5472 gp_message ("debugXL", $subr_name, $msg); 5473 5474 if ($src_line_no !~ /$qmark_regex/) 5475#------------------------------------------------------------------------------ 5476# The source code line number is known and is stored. 5477#------------------------------------------------------------------------------ 5478 { 5479 $source_line[$line_no] = $src_line_no; 5480 my $msg; 5481 $msg = "found an instruction with a source line ref: "; 5482 $msg .= "source_line[$line_no] = $source_line[$line_no]"; 5483 gp_message ("debugXL", $subr_name, $msg); 5484 } 5485 5486#------------------------------------------------------------------------------ 5487# Check for function calls. If found, get the address offset from $4 and 5488# compute the target address. 5489#------------------------------------------------------------------------------ 5490 ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) = 5491 check_and_proc_dis_func_call ( 5492 \$input_line, 5493 \$line_no, 5494 \%branch_target, 5495 \%extended_branch_target); 5496 $found_it = ${ $found_it_ref }; 5497 5498 if ($found_it) 5499 { 5500 %branch_target = %{ $branch_target_ref }; 5501 %extended_branch_target = %{ $extended_branch_target_ref }; 5502 } 5503 5504#------------------------------------------------------------------------------ 5505# Look for a branch instruction, or the special endbr32/endbr64 instruction 5506# that is also considered to be a branch target. Note that the latter is x86 5507# specific. 5508#------------------------------------------------------------------------------ 5509 ($found_it_ref, $branch_target_ref, $extended_branch_target_ref, 5510 $branch_target_no_ref_ref) = check_and_proc_dis_branches ( 5511 \$input_line, 5512 \$line_no, 5513 \%branch_target, 5514 \%extended_branch_target, 5515 \%branch_target_no_ref); 5516 $found_it = ${ $found_it_ref }; 5517 5518 if ($found_it) 5519 { 5520 %branch_target = %{ $branch_target_ref }; 5521 %extended_branch_target = %{ $extended_branch_target_ref }; 5522 %branch_target_no_ref = %{ $branch_target_no_ref_ref }; 5523 } 5524 } 5525 } #-- End of loop over line_no 5526 5527 %inverse_branch_target = reverse (%extended_branch_target); 5528 5529 gp_message ("debug", $subr_name, "generated inverse of branch target structure"); 5530 gp_message ("debug", $subr_name, "completed parsing file $filename"); 5531 5532 for my $key (sort keys %branch_target) 5533 { 5534 gp_message ("debug", $subr_name, "branch_target{$key} = $branch_target{$key}"); 5535 } 5536 for my $key (sort keys %extended_branch_target) 5537 { 5538 gp_message ("debug", $subr_name, "extended_branch_target{$key} = $extended_branch_target{$key}"); 5539 } 5540 for my $key (sort keys %inverse_branch_target) 5541 { 5542 gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}"); 5543 } 5544 for my $key (sort keys %branch_target_no_ref) 5545 { 5546 gp_message ("debug", $subr_name, "branch_target_no_ref{$key} = $branch_target_no_ref{$key}"); 5547 $inverse_branch_target{$key} = $key; 5548 } 5549 for my $key (sort keys %inverse_branch_target) 5550 { 5551 gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}"); 5552 } 5553 5554#------------------------------------------------------------------------------ 5555# Process the disassembly. 5556#------------------------------------------------------------------------------ 5557 5558#------------------------------------------------------------------------------ 5559# Dynamically generate the regexes. 5560#------------------------------------------------------------------------------ 5561 $metric_regex = ''; 5562 for my $metric_used (1 .. $number_of_metrics) 5563 { 5564 $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+'; 5565 } 5566 5567 $dis_regex = '^(#{2}|\s{2})\s+'; 5568 $dis_regex .= '(.*)'; 5569## $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)\s+(.*)'; 5570 $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)(.*)'; 5571 5572 gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex"); 5573 gp_message ("debugXL", $subr_name, "dis_regex = $dis_regex"); 5574 gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); 5575 gp_message ("debugXL", $subr_name, "contents of lines array"); 5576 5577#------------------------------------------------------------------------------ 5578# Identify the header lines. Make the minimal assumptions. 5579# 5580# In both cases, the first line after the header has whitespace. This is 5581# followed by: 5582# 5583# - A source line file has "<line_no>." 5584# - A dissasembly file has "<Function:" 5585# 5586# These are the characteristics we use below. 5587#------------------------------------------------------------------------------ 5588 for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++) 5589 { 5590 my $input_line = $disassembly_file[$line_no]; 5591 gp_message ("debugXL", $subr_name, "[line $line_no] $input_line"); 5592 5593 if ($input_line =~ /$end_src_header_regex/) 5594 { 5595 gp_message ("debugXL", $subr_name, "header time is over - hit source line\n"); 5596 gp_message ("debugXL", $subr_name, "$1 $2 $3\n"); 5597 last; 5598 } 5599 if ($input_line =~ /$end_dis_header_regex/) 5600 { 5601 gp_message ("debugXL", $subr_name, "header time is over - hit disassembly line\n"); 5602 last; 5603 } 5604 push (@modified_html, "<i>" . $input_line . "</i>"); 5605 5606 } 5607 my $line_index = scalar (@modified_html); 5608 gp_message ("debugXL", $subr_name, "final line_index = $line_index"); 5609 5610 for (my $line_no=0; $line_no <= $line_index-1; $line_no++) 5611 { 5612 my $msg = " modified_html[$line_no] = $modified_html[$line_no]"; 5613 gp_message ("debugXL", $subr_name, $msg); 5614 } 5615 5616#------------------------------------------------------------------------------ 5617# Source line: 5618# 20. for (int64_t r=0; r<repeat_count; r++) { 5619# 5620# Disassembly: 5621# 0.340 [37] 401fec: addsd %xmm0,%xmm1 5622# ## 1.311 [36] 401ff0: addq $1,%rax 5623#------------------------------------------------------------------------------ 5624 5625#------------------------------------------------------------------------------ 5626# Find the hot PCs and store them. 5627#------------------------------------------------------------------------------ 5628 my @hot_program_counters = (); 5629 my @transposed_hot_pc = (); 5630 my @max_metric_values = (); 5631 5632 gp_message ("debug", $subr_name, "determine the maximum metric values"); 5633 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) 5634 { 5635 my $input_line = $disassembly_file[$line_no]; 5636 5637 if ( $input_line =~ /$dis_regex/ ) 5638 { 5639## if ( defined ($1) and defined ($2) and defined ($3) and 5640## defined ($4) and defined ($5) and defined ($6) ) 5641 if ( defined ($1) and defined ($2) and defined ($3) and 5642 defined ($4) and defined ($5) ) 5643 { 5644 $hot_line = $1; 5645 $metric_values = $2; 5646 $src_line = $3; 5647 $dec_instr_address = bigint::hex ($4); 5648 $instruction = $5; 5649 if (defined ($6)) 5650 { 5651 my $white_space_regex = '\s*'; 5652 $operands = $6; 5653 $operands =~ s/$white_space_regex//; 5654 } 5655 5656 if ($hot_line eq "##") 5657 { 5658 my @metrics = split (" ", $metric_values); 5659 push (@hot_program_counters, [@metrics]); 5660 } 5661 } 5662 } 5663 } 5664 for my $row (keys @hot_program_counters) 5665 { 5666 my $msg = "$filename row[" . $row . "] = "; 5667 for my $col (keys @{$hot_program_counters[$row]}) 5668 { 5669 $msg .= "$hot_program_counters[$row][$col] "; 5670 $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col]; 5671 } 5672 gp_message ("debugXL", $subr_name, "hot PC = $msg"); 5673 } 5674 for my $row (keys @transposed_hot_pc) 5675 { 5676 my $msg = "$filename row[" . $row . "] = "; 5677 for my $col (keys @{$transposed_hot_pc[$row]}) 5678 { 5679 $msg .= "$transposed_hot_pc[$row][$col] "; 5680 } 5681 gp_message ("debugXL", $subr_name, "$filename transposed = $msg"); 5682 } 5683#------------------------------------------------------------------------------ 5684# Get the maximum metric values and if integer, convert to floating-point. 5685# Since it is easier, we transpose the array and access it over the columns. 5686#------------------------------------------------------------------------------ 5687 for my $row (0 .. $#transposed_hot_pc) 5688 { 5689 my $max_val = 0; 5690 for my $col (0 .. $#{$transposed_hot_pc[$row]}) 5691 { 5692 $max_val = max ($transposed_hot_pc[$row][$col], $max_val);; 5693 } 5694 if ($max_val =~ /$integer_regex/) 5695 { 5696 $max_val = sprintf ("%f", $max_val); 5697 } 5698 gp_message ("debugXL", $subr_name, "$filename row = $row max_val = $max_val"); 5699 push (@max_metric_values, $max_val); 5700 } 5701 5702 for my $metric (0 .. $#max_metric_values) 5703 { 5704 my $msg = "$filename maximum[$metric] = $max_metric_values[$metric]"; 5705 gp_message ("debugM", $subr_name, $msg); 5706 } 5707 5708#------------------------------------------------------------------------------ 5709# TBD - Integrate this better. 5710# 5711# Scan the instructions to find the instruction address range. This is used 5712# to determine if a branch is external to this function. 5713#------------------------------------------------------------------------------ 5714 $dec_instruction_start = undef; 5715 $dec_instruction_end = undef; 5716 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) 5717 { 5718 my $input_line = $disassembly_file[$line_no]; 5719 if ( $input_line =~ /$dis_regex/ ) 5720 { 5721# if ( defined ($1) and defined ($2) and defined ($3) and 5722## defined ($4) and defined ($5) and defined ($6) ) 5723 if ( defined ($1) and defined ($2) and defined ($3) and 5724 defined ($4) and defined ($5) ) 5725 { 5726 $hot_line = $1; 5727 $metric_values = $2; 5728 $src_line = $3; 5729 $dec_instr_address = bigint::hex ($4); 5730 $instruction = $5; 5731## $operands = $6; 5732 if (defined ($6)) 5733 { 5734 my $white_space_regex = '\s*'; 5735 $operands = $6; 5736 $operands =~ s/$white_space_regex//; 5737 } 5738 5739 if (defined ($dec_instruction_start)) 5740 { 5741 if ($dec_instr_address < $dec_instruction_start) 5742 { 5743 $dec_instruction_start = $dec_instr_address; 5744 } 5745 } 5746 else 5747 { 5748 $dec_instruction_start = $dec_instr_address; 5749 } 5750 if (defined ($dec_instruction_end)) 5751 { 5752 if ($dec_instr_address > $dec_instruction_end) 5753 { 5754 $dec_instruction_end = $dec_instr_address; 5755 } 5756 } 5757 else 5758 { 5759 $dec_instruction_end = $dec_instr_address; 5760 } 5761 } 5762 } 5763 } 5764 5765 if (defined ($dec_instruction_start) and defined ($dec_instruction_end)) 5766 { 5767 $hex_instruction_start = sprintf ("%x", $dec_instruction_start); 5768 $hex_instruction_end = sprintf ("%x", $dec_instruction_end); 5769 5770 my $msg; 5771 $msg = "$filename $func dec_instruction_start = " . 5772 "$dec_instruction_start (0x$hex_instruction_start)"; 5773 gp_message ("debugXL", $subr_name, $msg); 5774 $msg = "$filename $func dec_instruction_end = " . 5775 "$dec_instruction_end (0x$hex_instruction_end)"; 5776 gp_message ("debugXL", $subr_name, $msg); 5777 } 5778 5779#------------------------------------------------------------------------------ 5780# This is where all the results from above come together. 5781#------------------------------------------------------------------------------ 5782 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) 5783 { 5784 my $input_line = $disassembly_file[$line_no]; 5785 gp_message ("debugXL", $subr_name, "input_line[$line_no] = $input_line"); 5786 if ( $input_line =~ /$dis_regex/ ) 5787 { 5788 gp_message ("debugXL", $subr_name, "found a disassembly line: $input_line"); 5789 5790 if ( defined ($1) and defined ($2) and defined ($3) and 5791 defined ($4) and defined ($5) ) 5792 { 5793# $branch_target{$hex_branch_target} = 1; 5794# $extended_branch_target{$instruction_address} = $raw_hex_branch_target; 5795 $hot_line = $1; 5796 $metric_values = $2; 5797 $src_line = $3; 5798 $orig_hex_instr_address = $4; 5799 $instruction = $5; 5800## $operands = $6; 5801 5802 my $msg = "disassembly line: $1 $2 $3 $4 $5"; 5803 if (defined ($6)) 5804 { 5805 $msg .= " \$6 = $6"; 5806 my $white_space_regex = '\s*'; 5807 $operands = $6; 5808 $operands =~ s/$white_space_regex//; 5809 } 5810 gp_message ("debugXL", $subr_name, $msg); 5811 5812#------------------------------------------------------------------------------ 5813# Pad the line with the metrics to ensure correct alignment. 5814#------------------------------------------------------------------------------ 5815 my $the_length; 5816 my @split_metrics = split (" ", $metric_values); 5817 my $first_metric = $split_metrics[0]; 5818## if ($first_metric =~ /^\d+$/) 5819 if ($first_metric =~ /$first_integer_regex/) 5820 { 5821 $the_length = length ($first_metric); 5822 } 5823 else 5824 { 5825 my @fields = split (/$decimal_separator/, $first_metric); 5826 $the_length = length ($fields[0]); 5827 } 5828 my $spaces = $max_length_first_metric - $the_length; 5829 my $pad = ""; 5830 for my $p (1 .. $spaces) 5831 { 5832 $pad .= " "; 5833 } 5834 $metric_values = $pad . $metric_values; 5835 gp_message ("debugXL", $subr_name, "pad = $pad"); 5836 gp_message ("debugXL", $subr_name, "metric_values = $metric_values"); 5837 5838#------------------------------------------------------------------------------ 5839# Since the instruction address variable may change and because we need the 5840# original address without html controls, we use a new variable for the 5841# (potentially) modified address. 5842#------------------------------------------------------------------------------ 5843 $hex_instr_address = $orig_hex_instr_address; 5844 $add_new_line_before = $FALSE; 5845 $add_new_line_after = $FALSE; 5846 5847 if ($src_line eq "?") 5848 5849#------------------------------------------------------------------------------ 5850# There is no source line number. Do not add a link. 5851#------------------------------------------------------------------------------ 5852 { 5853 $modified_line = $hot_line . ' ' . $metric_values . ' [' . $src_line . '] '; 5854 gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line"); 5855 } 5856 else 5857 { 5858#------------------------------------------------------------------------------ 5859# There is a source line number. Mark it as link. 5860#------------------------------------------------------------------------------ 5861 $src_line_ref = "[<a href='#line_".$src_line."'>".$src_line."</a>]"; 5862 gp_message ("debugXL", $subr_name, "src_line_ref = $src_line_ref"); 5863 gp_message ("debugXL", $subr_name, "hex_instr_address = $hex_instr_address"); 5864 5865 $modified_line = $hot_line . ' ' . $metric_values . ' ' . $src_line_ref . ' '; 5866 gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line"); 5867 } 5868 5869#------------------------------------------------------------------------------ 5870# Mark control flow instructions. Several cases need to be distinguished. 5871# 5872# In all cases we give the instruction a specific color, mark it boldface 5873# and add a new-line after the instruction 5874#------------------------------------------------------------------------------ 5875 if ( ($instruction =~ /$control_flow_1_regex/) or 5876 ($instruction =~ /$control_flow_2_regex/) or 5877 ($instruction =~ /$control_flow_3_regex/) ) 5878 { 5879 gp_message ("debugXL", $subr_name, "instruction = $instruction is a control flow instruction"); 5880 5881 $add_new_line_after = $TRUE; 5882 5883 $boldface = $TRUE; 5884 $instruction = color_string ($instruction, $boldface, $g_html_color_scheme{"control_flow"}); 5885 } 5886 5887 if (exists ($extended_branch_target{$hex_instr_address})) 5888#------------------------------------------------------------------------------ 5889# This is a branch instruction and we need to add the target address. 5890# 5891# In case the target address is outside of this load object, the link is 5892# colored differently. 5893# 5894# TBD: Add the name and if possible, a working link to this code. 5895#------------------------------------------------------------------------------ 5896 { 5897 $branch_address = $extended_branch_target{$hex_instr_address}; 5898 5899 $dec_branch_address = bigint::hex ($branch_address); 5900 5901 if ( ($dec_branch_address >= $dec_instruction_start) and 5902 ($dec_branch_address <= $dec_instruction_end) ) 5903#------------------------------------------------------------------------------ 5904# The instruction is within the range. 5905#------------------------------------------------------------------------------ 5906 { 5907 $link = "[ <a href='#".$branch_address."'>".$branch_address."</a> ]"; 5908 } 5909 else 5910 { 5911#------------------------------------------------------------------------------ 5912# The instruction is outside of the range. Change the color of the link. 5913#------------------------------------------------------------------------------ 5914 gp_message ("debugXL", $subr_name, "address is outside of range"); 5915 5916 $link = "[ <a href='#".$branch_address; 5917 $link .= "' style='color:$g_html_color_scheme{'link_outside_range'}'>"; 5918 $link .= $branch_address."</a> ]"; 5919 } 5920 gp_message ("debugXL", $subr_name, "address exists new link = $link"); 5921 5922 $operands .= ' ' . $link; 5923 gp_message ("debugXL", $subr_name, "update #1 modified_line = $modified_line"); 5924 } 5925 if (exists ($branch_target_no_ref{$hex_instr_address})) 5926 { 5927 gp_message ("debugXL", $subr_name, "NEWBR branch_target_no_ref{$hex_instr_address} = $branch_target_no_ref{$hex_instr_address}"); 5928 } 5929## if (exists ($inverse_branch_target{$hex_instr_address}) or 5930## exists ($branch_target_no_ref{$hex_instr_address})) 5931 if (exists ($inverse_branch_target{$hex_instr_address})) 5932#------------------------------------------------------------------------------ 5933# This is a target address and we need to define the instruction address to be 5934# a label. 5935#------------------------------------------------------------------------------ 5936 { 5937 $add_new_line_before = $TRUE; 5938 5939 my $branch_target = $inverse_branch_target{$hex_instr_address}; 5940 my $target = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>:"; 5941 gp_message ("debugXL", $subr_name, "inverse exists - hex_instr_address = $hex_instr_address"); 5942 gp_message ("debugXL", $subr_name, "inverse exists - add a target target = $target"); 5943 5944 $hex_instr_address = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>"; 5945 gp_message ("debugXL", $subr_name, "update #2 hex_instr_address = $hex_instr_address"); 5946 gp_message ("debugXL", $subr_name, "update #2 modified_line = $modified_line"); 5947 } 5948 5949 $modified_line .= $hex_instr_address . ': ' . $instruction . ' ' . $operands; 5950 5951 gp_message ("debugXL", $subr_name, "final modified_line = $modified_line"); 5952 5953#------------------------------------------------------------------------------ 5954# This is a control flow instruction, but it is the last one and we do not 5955# want to add a newline. 5956#------------------------------------------------------------------------------ 5957 gp_message ("debugXL", $subr_name, "decide where the <br> should go in the html"); 5958 gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after"); 5959 gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before"); 5960 5961 if ( $add_new_line_after and ($orig_hex_instr_address eq $hex_instruction_end) ) 5962 { 5963 $add_new_line_after = $FALSE; 5964 gp_message ("debugXL", $subr_name, "$instruction is the last instruction - do not add a newline"); 5965 } 5966 5967 if ($add_new_line_before) 5968 { 5969 5970#------------------------------------------------------------------------------ 5971# Get the previous line, if any, so that we can check what it is. 5972#------------------------------------------------------------------------------ 5973 my $prev_line = pop (@modified_html); 5974 if ( defined ($prev_line) ) 5975 { 5976 gp_message ("debugXL", $subr_name, "prev_line = $prev_line"); 5977 5978#------------------------------------------------------------------------------ 5979# Restore the previously popped line. 5980#------------------------------------------------------------------------------ 5981 push (@modified_html, $prev_line); 5982 if ($prev_line ne $html_new_line) 5983 { 5984 gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before pushed $html_new_line"); 5985#------------------------------------------------------------------------------ 5986# There is no new-line yet, so add it. 5987#------------------------------------------------------------------------------ 5988 push (@modified_html, $html_new_line); 5989 } 5990 else 5991 { 5992#------------------------------------------------------------------------------ 5993# It was a new-line, so do nothing and continue. 5994#------------------------------------------------------------------------------ 5995 gp_message ("debugXL", $subr_name, "need to restore $html_new_line"); 5996 } 5997 } 5998 } 5999#------------------------------------------------------------------------------ 6000# Add the newly created line. 6001#------------------------------------------------------------------------------ 6002 6003 if ($hot_line eq "##") 6004#------------------------------------------------------------------------------ 6005# Highlight the most expensive line. 6006#------------------------------------------------------------------------------ 6007 { 6008 $modified_line = set_background_color_string ( 6009 $modified_line, 6010 $g_html_color_scheme{"background_color_hot"}); 6011 } 6012#------------------------------------------------------------------------------ 6013# Sub-highlight the lines close enough to the hot line. 6014#------------------------------------------------------------------------------ 6015 else 6016 { 6017 my @current_metrics = split (" ", $metric_values); 6018 for my $metric (0 .. $#current_metrics) 6019 { 6020 my $current_value; 6021 my $max_value; 6022 $current_value = $current_metrics[$metric]; 6023#------------------------------------------------------------------------------ 6024# As part of the padding process, non-breaking spaces may have been inserted 6025# in an earlier phase. Temporarily remove these to make sure that the maximum 6026# metric values can be computed. 6027#------------------------------------------------------------------------------ 6028 $current_value =~ s/ //g; 6029 if (exists ($max_metric_values[$metric])) 6030 { 6031 $max_value = $max_metric_values[$metric]; 6032 gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); 6033 if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) ) 6034 { 6035# TBD: abs needed? 6036 gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); 6037 my $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value ); 6038 gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance"); 6039 if (($hp_value > 0) and ($relative_distance >= $hp_value/100.0)) 6040 { 6041 gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance"); 6042 gp_message ("debugXL", $subr_name, "change bg modified_line = $modified_line"); 6043 $modified_line = set_background_color_string ( 6044 $modified_line, 6045 $g_html_color_scheme{"background_color_lukewarm"}); 6046 last; 6047 } 6048 } 6049 } 6050 } 6051 } 6052 6053## my @max_metric_values = (); 6054 push (@modified_html, $modified_line); 6055 if ($add_new_line_after) 6056 { 6057 gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after pushed $html_new_line"); 6058 push (@modified_html, $html_new_line); 6059 } 6060 6061 } 6062 else 6063 { 6064 my $msg = "parsing line $input_line"; 6065 gp_message ("assertion", $subr_name, $msg); 6066 } 6067 } 6068 elsif ( $input_line =~ /$src_regex/ ) 6069 { 6070 if ( defined ($1) and defined ($2) ) 6071 { 6072####### BUG? 6073 gp_message ("debugXL", $subr_name, "found a source code line: $input_line"); 6074 gp_message ("debugXL", $subr_name, "\$1 = $1"); 6075 gp_message ("debugXL", $subr_name, "\$2 = $2"); 6076 gp_message ("debugXL", $subr_name, "\$3 = $3"); 6077 my $blanks = $1; 6078 my $src_line = $2; 6079 my $src_code = $3; 6080 6081#------------------------------------------------------------------------------ 6082# We need to replace the "<" symbol in the code by "<". 6083#------------------------------------------------------------------------------ 6084 $src_code =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 6085 6086 my $target = "<a name='line_".$src_line."'>".$src_line.".</a>"; 6087 gp_message ("debugXL", $subr_name, "src target = $target $src_code"); 6088 6089 my $modified_line = $blanks . $target . $src_code; 6090 gp_message ("debugXL", $subr_name, "modified_line = $modified_line"); 6091 push (@modified_html, $modified_line); 6092 } 6093 else 6094 { 6095 my $msg = "parsing line $input_line"; 6096 gp_message ("assertion", $subr_name, $msg); 6097 } 6098 } 6099 elsif ( $input_line =~ /$function_regex/ ) 6100 { 6101 my $html_name; 6102 if (defined ($1) and defined ($2)) 6103 { 6104 $func_name_in_dis_file = $2; 6105 my $spaces = $1; 6106 my $boldface = $TRUE; 6107 gp_message ("debugXL", $subr_name, "function_name = $2"); 6108 my $function_line = "<Function: " . $func_name_in_dis_file . ">"; 6109 6110##### HACK 6111 6112 if ($func_name_in_dis_file eq $target_function) 6113 { 6114 my $color_function_name = color_string ( 6115 $function_line, 6116 $boldface, 6117 $g_html_color_scheme{"target_function_name"}); 6118 my $label = "<a id=\"" . $g_function_tag_id{$target_function} . "\"></a>"; 6119 $html_name = $label . $spaces . "<i>" . $color_function_name . "</i>"; 6120 } 6121 else 6122 { 6123 my $color_function_name = color_string ( 6124 $function_line, 6125 $boldface, 6126 $g_html_color_scheme{"non_target_function_name"}); 6127 $html_name = "<i>" . $spaces . $color_function_name . "</i>"; 6128 } 6129 push (@modified_html, $html_name); 6130 } 6131 else 6132 { 6133 my $msg = "parsing line $input_line"; 6134 gp_message ("assertion", $subr_name, $msg); 6135 } 6136 } 6137 } 6138 6139#------------------------------------------------------------------------------ 6140# Add an extra line with diagnostics. 6141# 6142# TBD: The same is done in process_source but should be done only once. 6143#------------------------------------------------------------------------------ 6144 if ($hp_value > 0) 6145 { 6146 my $rounded_percentage = sprintf ("%.1f", $hp_value); 6147 $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>"; 6148 } 6149 else 6150 { 6151 $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>"; 6152 } 6153 6154 $html_home = ${ generate_home_link ("left") }; 6155 $html_end = ${ terminate_html_document () }; 6156 6157 push (@modified_html, "</pre>"); 6158 push (@modified_html, $html_new_line); 6159 push (@modified_html, $threshold_line); 6160 push (@modified_html, $html_home); 6161 push (@modified_html, $html_new_line); 6162 push (@modified_html, $g_html_credits_line); 6163 push (@modified_html, $html_end); 6164 6165 for my $i (0 .. $#modified_html) 6166 { 6167 gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]"); 6168 } 6169 6170 for my $i (0 .. $#modified_html) 6171 { 6172 print HTML_OUTPUT "$modified_html[$i]" . "\n"; 6173 } 6174 6175 close (HTML_OUTPUT); 6176 close (INPUT_DISASSEMBLY); 6177 6178 gp_message ("debug", $subr_name, "output is in file $html_dis_out"); 6179 gp_message ("debug", $subr_name ,"completed processing disassembly"); 6180 6181 undef %branch_target; 6182 undef %extended_branch_target; 6183 undef %inverse_branch_target; 6184 6185 return (\@source_line, \@metric); 6186 6187} #-- End of subroutine generate_dis_html 6188 6189#------------------------------------------------------------------------------ 6190# Generate all the function level information. 6191#------------------------------------------------------------------------------ 6192sub generate_function_level_info 6193{ 6194 my $subr_name = get_my_name (); 6195 6196 my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string, 6197 $sort_fields_ref) = @_; 6198 6199 my @exp_dir_list = @{ $exp_dir_list_ref }; 6200 my @sort_fields = @{ $sort_fields_ref }; 6201 6202 my $expr_name; 6203 my $first_metric; 6204 my $gp_display_text_cmd; 6205 my $gp_functions_cmd; 6206 my $ignore_value; 6207 my $script_pc_metrics; 6208 6209 my $outputdir = append_forward_slash ($input_string); 6210 6211 my $script_file_PC = $outputdir."gp-script-PC"; 6212 my $result_file = $outputdir."gp-out-PC.err"; 6213 my $gp_error_file = $outputdir."gp-out-PC.err"; 6214 my $func_limit = $g_user_settings{func_limit}{current_value}; 6215 6216#------------------------------------------------------------------------------ 6217# The number of entries in the Function Overview includes <Total>, but that is 6218# not a concern to the user and we add "1" to compensate for this. 6219#------------------------------------------------------------------------------ 6220 $func_limit += 1; 6221 6222 gp_message ("debug", $subr_name, "increased the local value for func_limit = $func_limit"); 6223 6224 $expr_name = join (" ", @exp_dir_list); 6225 6226 gp_message ("debug", $subr_name, "expr_name = $expr_name"); 6227 6228 for my $i (0 .. $#sort_fields) 6229 { 6230 gp_message ("debug", $subr_name, "sort_fields[$i] = $sort_fields[$i]"); 6231 } 6232 6233# Ruud $count = 0; 6234 6235 gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files"); 6236 6237 open (SCRIPT_PC, ">", $script_file_PC) 6238 or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'"); 6239 gp_message ("debug", $subr_name, "opened file $script_file_PC for writing"); 6240 6241#------------------------------------------------------------------------------ 6242# Get the list of functions. 6243#------------------------------------------------------------------------------ 6244 6245#------------------------------------------------------------------------------ 6246# Get the first metric. 6247#------------------------------------------------------------------------------ 6248 $summary_metrics =~ /^([^:]+)/; 6249 $first_metric = $1; 6250 $g_first_metric = $1; 6251 $script_pc_metrics = "address:$summary_metrics"; 6252 6253 gp_message ("debugXL", $subr_name, "$func_limit"); 6254 gp_message ("debugXL", $subr_name, "$summary_metrics"); 6255 gp_message ("debugXL", $subr_name, "$first_metric"); 6256 gp_message ("debugXL", $subr_name, "$script_pc_metrics"); 6257 6258# Temporarily disabled print SCRIPT_PC "# limit $func_limit\n"; 6259# Temporarily disabled print SCRIPT_PC "limit $func_limit\n"; 6260 print SCRIPT_PC "# thread_select all\n"; 6261 print SCRIPT_PC "thread_select all\n"; 6262 6263#------------------------------------------------------------------------------ 6264# Empty header. 6265#------------------------------------------------------------------------------ 6266 print SCRIPT_PC "# outfile $outputdir"."header\n"; 6267 print SCRIPT_PC "outfile $outputdir"."header\n"; 6268 6269#------------------------------------------------------------------------------ 6270# Else the output from the next line goes to last sort.func 6271#------------------------------------------------------------------------------ 6272 print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n"; 6273 print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n"; 6274 print SCRIPT_PC "# metrics $script_pc_metrics\n"; 6275 print SCRIPT_PC "metrics $script_pc_metrics\n"; 6276#------------------------------------------------------------------------------ 6277# Not really sorted 6278#------------------------------------------------------------------------------ 6279 print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n"; 6280 print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n"; 6281 print SCRIPT_PC "# functions\n"; 6282 print SCRIPT_PC "functions\n"; 6283 6284 print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n"; 6285 print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n"; 6286 print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; 6287 print SCRIPT_PC "metrics address:name:$summary_metrics\n"; 6288 print SCRIPT_PC "# sort $first_metric\n"; 6289 print SCRIPT_PC "sort $first_metric\n"; 6290 print SCRIPT_PC "# functions\n"; 6291 print SCRIPT_PC "functions\n"; 6292#------------------------------------------------------------------------------ 6293# Go through all the possible metrics and sort by each of them. 6294#------------------------------------------------------------------------------ 6295 for my $field (@sort_fields) 6296 { 6297 gp_message ("debug", $subr_name, "sort_fields field = $field"); 6298#------------------------------------------------------------------------------ 6299# Else the output from the next line goes to last sort.func 6300#------------------------------------------------------------------------------ 6301 print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n"; 6302 print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n"; 6303 print SCRIPT_PC "# metrics $script_pc_metrics\n"; 6304 print SCRIPT_PC "metrics $script_pc_metrics\n"; 6305 print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC\n"; 6306 print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC\n"; 6307 print SCRIPT_PC "# sort $field\n"; 6308 print SCRIPT_PC "sort $field\n"; 6309 print SCRIPT_PC "# functions\n"; 6310 print SCRIPT_PC "functions\n"; 6311 6312 print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; 6313 print SCRIPT_PC "metrics address:name:$summary_metrics\n"; 6314 print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC2\n"; 6315 print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC2\n"; 6316 print SCRIPT_PC "# sort $field\n"; 6317 print SCRIPT_PC "sort $field\n"; 6318 print SCRIPT_PC "# functions\n"; 6319 print SCRIPT_PC "functions\n"; 6320 } 6321 6322#------------------------------------------------------------------------------ 6323# Get caller-callee list 6324#------------------------------------------------------------------------------ 6325 print SCRIPT_PC "# outfile " . $outputdir."caller-callee-PC2\n"; 6326 print SCRIPT_PC "outfile " . $outputdir."caller-callee-PC2\n"; 6327 print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; 6328 print SCRIPT_PC "metrics address:name:$summary_metrics\n"; 6329 print SCRIPT_PC "# callers-callees\n"; 6330 print SCRIPT_PC "callers-callees\n"; 6331#------------------------------------------------------------------------------ 6332# Else the output from the next line goes to last sort.func 6333#------------------------------------------------------------------------------ 6334 print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n"; 6335 print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n"; 6336 $script_pc_metrics = "address:$call_metrics"; 6337 print SCRIPT_PC "# metrics $script_pc_metrics\n"; 6338 print SCRIPT_PC "metrics $script_pc_metrics\n"; 6339 6340#------------------------------------------------------------------------------ 6341# Not really sorted 6342#------------------------------------------------------------------------------ 6343 print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n"; 6344 print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n"; 6345 6346#------------------------------------------------------------------------------ 6347# Get caller-callee list 6348#------------------------------------------------------------------------------ 6349 print SCRIPT_PC "# callers-callees\n"; 6350 print SCRIPT_PC "callers-callees\n"; 6351 6352#------------------------------------------------------------------------------ 6353# Else the output from the next line goes to last sort.func 6354#------------------------------------------------------------------------------ 6355 print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calltree-PC\n"; 6356 print SCRIPT_PC "outfile $outputdir"."gp-metrics-calltree-PC\n"; 6357 print SCRIPT_PC "# metrics $script_pc_metrics\n"; 6358 print SCRIPT_PC "metrics $script_pc_metrics\n"; 6359 6360 if ($g_user_settings{"calltree"}{"current_value"} eq "on") 6361 { 6362 gp_message ("verbose", $subr_name, "Generate the file with the calltree information"); 6363#------------------------------------------------------------------------------ 6364# Get calltree list 6365#------------------------------------------------------------------------------ 6366 print SCRIPT_PC "# outfile $outputdir"."calltree.sort.func-PC\n"; 6367 print SCRIPT_PC "outfile $outputdir"."calltree.sort.func-PC\n"; 6368 print SCRIPT_PC "# calltree\n"; 6369 print SCRIPT_PC "calltree\n"; 6370 } 6371 6372#------------------------------------------------------------------------------ 6373# Get the default set of metrics 6374#------------------------------------------------------------------------------ 6375 my $full_metrics_ref; 6376 my $all_metrics; 6377 my $full_function_view = $outputdir . "functions.full"; 6378 6379 $full_metrics_ref = get_all_the_metrics (\$expr_name, \$outputdir); 6380 6381 $all_metrics = "address:name:"; 6382 $all_metrics .= ${$full_metrics_ref}; 6383 gp_message ("debug", $subr_name, "all_metrics = $all_metrics"); 6384#------------------------------------------------------------------------------ 6385# Get the name, address, and full overview of all metrics for all functions 6386#------------------------------------------------------------------------------ 6387 print SCRIPT_PC "# limit 0\n"; 6388 print SCRIPT_PC "limit 0\n"; 6389 print SCRIPT_PC "# metrics $all_metrics\n"; 6390 print SCRIPT_PC "metrics $all_metrics\n"; 6391 print SCRIPT_PC "# thread_select all\n"; 6392 print SCRIPT_PC "thread_select all\n"; 6393 print SCRIPT_PC "# sort default\n"; 6394 print SCRIPT_PC "sort default\n"; 6395 print SCRIPT_PC "# outfile $full_function_view\n"; 6396 print SCRIPT_PC "outfile $full_function_view\n"; 6397 print SCRIPT_PC "# functions\n"; 6398 print SCRIPT_PC "functions\n"; 6399 6400 close (SCRIPT_PC); 6401 6402 $result_file = $outputdir."gp-out-PC.err"; 6403 $gp_error_file = $outputdir.$g_gp_error_logfile; 6404 6405 $gp_functions_cmd = "$GP_DISPLAY_TEXT -limit $func_limit "; 6406 $gp_functions_cmd .= "-viewmode machine -compare off "; 6407 $gp_functions_cmd .= "-script $script_file_PC $expr_name"; 6408 6409 gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function level information"); 6410 6411 $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file"; 6412 6413 gp_message ("debugXL", $subr_name,"cmd = $gp_display_text_cmd"); 6414 6415 my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 6416 6417 if ($error_code != 0) 6418 { 6419 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 6420 $error_code, 6421 $gp_error_file); 6422 gp_message ("abort", "execution terminated"); 6423 } 6424 6425#------------------------------------------------------------------------------- 6426# Parse the full function view and store the data. 6427#------------------------------------------------------------------------------- 6428 my @input_data = (); 6429 my $empty_line_regex = '^\s*$'; 6430 6431## my $full_function_view = $outputdir . "functions.full"; 6432 6433 open (ALL_FUNC_DATA, "<", $full_function_view) 6434 or die ("$subr_name - unable to open output file $full_function_view for reading '$!'"); 6435 gp_message ("debug", $subr_name, "opened file $full_function_view for reading"); 6436 6437 chomp (@input_data = <ALL_FUNC_DATA>); 6438 6439 my $start_scanning = $FALSE; 6440 for (my $line = 0; $line <= $#input_data; $line++) 6441 { 6442 my $input_line = $input_data[$line]; 6443 6444# if ($input_line =~ /^<Total>\s+.*/) 6445 if ($input_line =~ /\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)/) 6446 { 6447 $start_scanning = $TRUE; 6448 } 6449 elsif ($input_line =~ /$empty_line_regex/) 6450 { 6451 $start_scanning = $FALSE; 6452 } 6453 6454 if ($start_scanning) 6455 { 6456 gp_message ("debugXL", $subr_name, "$line: $input_data[$line]"); 6457 6458 push (@g_full_function_view_table, $input_data[$line]); 6459 6460 my $hex_address; 6461 my $full_hex_address = $1; 6462 my $routine = $2; 6463 my $all_metrics = $3; 6464 if ($full_hex_address =~ /(\d+):0x(\S+)/) 6465 { 6466 $hex_address = "0x" . $2; 6467 } 6468 $g_function_view_all{$routine}{"hex_address"} = $hex_address; 6469 $g_function_view_all{$routine}{"all_metrics"} = $all_metrics; 6470 } 6471 } 6472 6473 for my $i (keys %g_function_view_all) 6474 { 6475 gp_message ("debugXL", $subr_name, "key = $i $g_function_view_all{$i}{'hex_address'} $g_function_view_all{$i}{'all_metrics'}"); 6476 } 6477 6478 for my $i (keys @g_full_function_view_table) 6479 { 6480 gp_message ("debugXL", $subr_name, "g_full_function_view_table[$i] = $i $g_full_function_view_table[$i]"); 6481 } 6482 6483 return ($script_pc_metrics); 6484 6485} #-- End of subroutine generate_function_level_info 6486 6487#------------------------------------------------------------------------------ 6488# Generate all the files needed for the function view. 6489#------------------------------------------------------------------------------ 6490sub generate_function_view 6491{ 6492 my $subr_name = get_my_name (); 6493 6494 my ($directory_name_ref, $summary_metrics_ref, $number_of_metrics_ref, 6495 $function_info_ref, $function_view_structure_ref, $function_address_info_ref, 6496 $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref) = @_; 6497 6498 my $directory_name = ${ $directory_name_ref }; 6499 my @function_info = @{ $function_info_ref }; 6500 my %function_view_structure = %{ $function_view_structure_ref }; 6501 my $summary_metrics = ${ $summary_metrics_ref }; 6502 my $number_of_metrics = ${ $number_of_metrics_ref }; 6503 my %function_address_info = %{ $function_address_info_ref }; 6504 my @sort_fields = @{ $sort_fields_ref }; 6505 my @exp_dir_list = @{ $exp_dir_list_ref }; 6506 my %addressobjtextm = %{ $addressobjtextm_ref }; 6507 6508 my @abs_path_exp_dirs = (); 6509 my @experiment_directories; 6510 6511 my $target_function; 6512 my $html_line; 6513 my $ftag; 6514 my $routine_length; 6515 my %html_source_functions = (); 6516 6517 my $href_link; 6518 my $infile; 6519 my $input_experiments; 6520 my $keep_value; 6521 my $loadobj; 6522 my $address_field; 6523 my $address_offset; 6524 my $msg; 6525 my $exe; 6526 my $extra_field; 6527 my $new_target_function; 6528 my $file_title; 6529 my $html_output_file; 6530 my $html_function_view; 6531 my $overview_file; 6532 my $exp_name; 6533 my $exp_type; 6534 my $html_header; 6535 my $routine; 6536 my $length_header; 6537 my $length_metrics; 6538 my $full_index_line; 6539 my $acknowledgement; 6540 my @full_function_view_line = (); 6541 my $spaces; 6542 my $size_text; 6543 my $position_text; 6544 my $html_first_metric_file; 6545 my $html_new_line = "<br>"; 6546 my $html_acknowledgement; 6547 my $html_end; 6548 my $html_home; 6549 my $page_title; 6550 my $html_title_header; 6551 6552 my $outputdir = append_forward_slash ($directory_name); 6553 my $LANG = $g_locale_settings{"LANG"}; 6554 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 6555 6556 $input_experiments = join (", ", @exp_dir_list); 6557 6558 for my $i (0 .. $#exp_dir_list) 6559 { 6560 my $dir = get_basename ($exp_dir_list[$i]); 6561 push @abs_path_exp_dirs, $dir; 6562 } 6563 $input_experiments = join (", ", @abs_path_exp_dirs); 6564 6565 gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); 6566 6567#------------------------------------------------------------------------------ 6568# TBD: This should be done only once and much earlier. 6569#------------------------------------------------------------------------------ 6570 @experiment_directories = split (",", $input_experiments); 6571 6572#------------------------------------------------------------------------------ 6573# For every function in the function overview, set up an html structure with 6574# the various hyperlinks. 6575#------------------------------------------------------------------------------ 6576 6577#------------------------------------------------------------------------------ 6578# Core loop that generates an HTML line for each function. 6579#------------------------------------------------------------------------------ 6580 my $top_of_table = $FALSE; 6581 for my $i (0 .. $#function_info) 6582 { 6583 if (defined ($function_info[$i]{"alt_name"})) 6584 { 6585 $target_function = $function_info[$i]{"alt_name"}; 6586 } 6587 else 6588 { 6589 my $msg = "function_info[$i]{\"alt_name\"} is not defined"; 6590 gp_message ("assertion", $subr_name, $msg); 6591 } 6592 6593 $html_source_functions{$target_function} = $function_info[$i]{"html function block"}; 6594 } 6595 6596 for my $i (sort keys %html_source_functions) 6597 { 6598 gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}"); 6599 } 6600 6601 $file_title = "Function view for experiments " . $input_experiments; 6602 6603#------------------------------------------------------------------------------ 6604# Example input file: 6605 6606# Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm 6607# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 6608# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 6609# Functions sorted by metric: Exclusive Total CPU Time 6610# 6611# PC Addr. Name Excl. Excl. CPU Excl. Excl. 6612# Total Cycles Instructions Last-Level 6613# CPU sec. sec. Executed Cache Misses 6614# 1:0x00000000 <Total> 3.502 4.005 15396819700 24024250 6615# 2:0x000021ae mxv_core 3.342 3.865 14500538981 23824045 6616# 6:0x0003af50 erand48_r 0.080 0.084 768240570 0 6617# 2:0x00001f7b init_data 0.040 0.028 64020043 200205 6618# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 6619# ... 6620#------------------------------------------------------------------------------ 6621 6622 for my $metric (@sort_fields) 6623 { 6624 $overview_file = $outputdir . $metric . ".sort.func-PC2"; 6625 6626 $exp_type = $metric; 6627 6628 if ($metric eq "functions") 6629 { 6630 $html_function_view .= $g_html_base_file_name{"function_view"} . ".html"; 6631 } 6632 else 6633 { 6634 $html_function_view = $g_html_base_file_name{"function_view"} . "." . $metric . ".html"; 6635 } 6636#------------------------------------------------------------------------------ 6637# The default function view is based upon the first metric in the list. We use 6638# this file in the index.html file. 6639#------------------------------------------------------------------------------ 6640 if ($metric eq $g_first_metric) 6641 { 6642 $html_first_metric_file = $html_function_view; 6643 my $txt = "g_first_metric = $g_first_metric "; 6644 $txt .= "html_first_metric_file = $html_first_metric_file"; 6645 gp_message ("debugXL", $subr_name, $txt); 6646 } 6647 6648 $html_output_file = $outputdir . $html_function_view; 6649 6650 open (FUNCTION_VIEW, ">", $html_output_file) 6651 or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); 6652 gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); 6653 6654 $html_home = ${ generate_home_link ("right") }; 6655 $html_header = ${ create_html_header (\$file_title) }; 6656 6657 $page_title = "Function View"; 6658 $size_text = "h2"; 6659 $position_text = "center"; 6660 $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 6661 6662 print FUNCTION_VIEW $html_header; 6663 print FUNCTION_VIEW $html_home; 6664 print FUNCTION_VIEW $html_title_header; 6665 print FUNCTION_VIEW "$_" for @g_html_experiment_stats; 6666 print FUNCTION_VIEW $html_new_line . "\n"; 6667 6668 my $function_view_structure_ref = process_function_overview ( 6669 \$metric, 6670 \$exp_type, 6671 \$summary_metrics, 6672 \$number_of_metrics, 6673 \@function_info, 6674 \%function_view_structure, 6675 \$overview_file); 6676 6677 my %function_view_structure = %{ $function_view_structure_ref }; 6678 6679#------------------------------------------------------------------------------ 6680# Core part: extract the true function name and find the html code for it. 6681#------------------------------------------------------------------------------ 6682 gp_message ("debugXL", $subr_name, "the final table"); 6683 6684 print FUNCTION_VIEW "<pre>\n"; 6685 print FUNCTION_VIEW "$_\n" for @{ $function_view_structure{"header"} }; 6686 6687 my $max_length_header = $function_view_structure{"max header length"}; 6688 my $max_length_metrics = $function_view_structure{"max metrics length"}; 6689 6690#------------------------------------------------------------------------------ 6691# Add 4 more spaces for the distance to the function names. Purely cosmetic. 6692#------------------------------------------------------------------------------ 6693 my $pad = max ($max_length_metrics, $max_length_header) + 4; 6694 my $spaces = ""; 6695 for my $i (1 .. $pad) 6696 { 6697 $spaces .= " "; 6698 } 6699 6700#------------------------------------------------------------------------------ 6701# Add extra space for the /blank/*/ marker! 6702#------------------------------------------------------------------------------ 6703 $spaces .= " "; 6704 my $func_header = $spaces . $function_view_structure{"table name"}; 6705 gp_message ("debugXL", $subr_name, "func_header = " . $func_header); 6706 6707 6708 print FUNCTION_VIEW $spaces . "<b>" . 6709 $function_view_structure{"table name"} . 6710 "</b>" . $html_new_line . "\n"; 6711 6712#------------------------------------------------------------------------------ 6713# If the header is longer than the metrics, add spaces to padd the difference. 6714# Also add the same 4 spaces between the metric values and the function name. 6715#------------------------------------------------------------------------------ 6716 $pad = 0; 6717 if ($max_length_header > $max_length_metrics) 6718 { 6719 $pad = $max_length_header - $max_length_metrics; 6720 } 6721 $pad += 4; 6722 $spaces = ""; 6723 for my $i (1 .. $pad) 6724 { 6725 $spaces .= " "; 6726 } 6727 6728#------------------------------------------------------------------------------ 6729# This is where it literally all comes together. The metrics and function 6730# parts are combined. 6731#------------------------------------------------------------------------------ 6732## for my $i (keys @{ $function_view_structure{"function table"} }) 6733 for my $i (0 .. $#{ $function_view_structure{"function table"} }) 6734 { 6735 my $p1 = $function_view_structure{"metrics part"}[$i]; 6736 my $p2 = $function_view_structure{"function table"}[$i]; 6737 6738 $full_index_line = $p1 . $spaces . $p2; 6739 6740 push (@full_function_view_line, $full_index_line); 6741 } 6742 6743 print FUNCTION_VIEW "$_\n" for @full_function_view_line; 6744 6745#------------------------------------------------------------------------------- 6746# Clear the array before filling it up again. 6747#------------------------------------------------------------------------------- 6748 @full_function_view_line = (); 6749 6750#------------------------------------------------------------------------------- 6751# Get the acknowledgement, return to main link, and final html statements. 6752#------------------------------------------------------------------------------- 6753 $html_home = ${ generate_home_link ("left") }; 6754 $html_acknowledgement = ${ create_html_credits () }; 6755 $html_end = ${ terminate_html_document () }; 6756 6757 print FUNCTION_VIEW "</pre>\n"; 6758 print FUNCTION_VIEW $html_home; 6759 print FUNCTION_VIEW $html_new_line . "\n"; 6760 print FUNCTION_VIEW $html_acknowledgement; 6761 print FUNCTION_VIEW $html_end; 6762 6763 close (FUNCTION_VIEW); 6764 } 6765 6766 return (\$html_first_metric_file); 6767 6768} #-- End of subroutine generate_function_view 6769 6770#------------------------------------------------------------------------------ 6771# Generate an html line that links back to index.html. The text can either 6772# be positioned to the left or to the right. 6773#------------------------------------------------------------------------------ 6774sub generate_home_link 6775{ 6776 my $subr_name = get_my_name (); 6777 6778 my ($which_side) = @_; 6779 6780 my $html_home_line; 6781 6782 if (($which_side ne "left") and ($which_side ne "right")) 6783 { 6784 my $msg = "which_side = $which_side not supported"; 6785 gp_message ("assertion", $subr_name, $msg); 6786 } 6787 6788 $html_home_line .= "<div class=\"" . $which_side . "\">"; 6789 $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"}; 6790 $html_home_line .= ".html' style='background-color:"; 6791 $html_home_line .= $g_html_color_scheme{"index"}; 6792 $html_home_line .= "'><b>Return to main view</b></a>"; 6793 $html_home_line .= "</div>"; 6794 6795 return (\$html_home_line); 6796 6797} #-- End of subroutine generate_home_link 6798 6799#------------------------------------------------------------------------------ 6800# Generate a block of html for this function block. 6801#------------------------------------------------------------------------------ 6802sub generate_html_function_blocks 6803{ 6804 my $subr_name = get_my_name (); 6805 6806 my ( 6807 $index_start_ref, 6808 $index_end_ref, 6809 $hex_addresses_ref, 6810 $the_metrics_ref, 6811 $length_first_metric_ref, 6812 $special_marker_ref, 6813 $the_function_name_ref, 6814 $separator_ref, 6815 $number_of_metrics_ref, 6816 $data_function_block_ref, 6817 $function_info_ref, 6818 $function_view_structure_ref) = @_; 6819 6820 my $index_start = ${ $index_start_ref }; 6821 my $index_end = ${ $index_end_ref }; 6822 my @hex_addresses = @{ $hex_addresses_ref }; 6823 my @the_metrics = @{ $the_metrics_ref }; 6824 my @length_first_metric = @{ $length_first_metric_ref }; 6825 my @special_marker = @{ $special_marker_ref }; 6826 my @the_function_name = @{ $the_function_name_ref}; 6827 6828 my $separator = ${ $separator_ref }; 6829 my $number_of_metrics = ${ $number_of_metrics_ref }; 6830 my $data_function_block = ${ $data_function_block_ref }; 6831 my @function_info = @{ $function_info_ref }; 6832 my %function_view_structure = %{ $function_view_structure_ref }; 6833 6834 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 6835 6836 my @html_block_prologue = (); 6837 my @html_code_function_block = (); 6838 my @function_lines = (); 6839 my @fields = (); 6840 my @address_field = (); 6841 my @metric_values = (); 6842 my @function_names = (); 6843 my @final_function_names = (); 6844 my @marker = (); 6845 my @split_number = (); 6846 my @function_tags = (); 6847 6848 my $all_metrics; 6849 my $current_function_name; 6850 my $no_of_fields; 6851 my $name_regex; 6852 my $full_hex_address; 6853 my $hex_address; 6854 my $target_function; 6855 my $marker_function; 6856 my $routine; 6857 my $routine_length; 6858 my $metrics_length; 6859 my $max_metrics_length = 0; 6860 my $modified_line; 6861 my $string_length; 6862 my $addr_offset; 6863 my $current_address; 6864 my $found_a_match; 6865 my $ref_index; 6866 my $alt_name; 6867 my $length_first_field; 6868 my $gap; 6869 my $ipad; 6870 my $html_line; 6871 my $target_tag; 6872 my $tag_for_header; 6873 my $href_file; 6874 my $found_alt_name; 6875 my $name_in_header; 6876 my $create_hyperlinks; 6877 6878 state $first_call = $TRUE; 6879 state $reference_length; 6880 6881#------------------------------------------------------------------------------ 6882# If the length of the first metric is less than the maximum over all first 6883# metrics, add spaces to the left to ensure correct alignment. 6884#------------------------------------------------------------------------------ 6885 for my $k ($index_start .. $index_end) 6886 { 6887 my $pad = $g_max_length_first_metric - $length_first_metric[$k]; 6888 if ($pad ge 1) 6889 { 6890 my $spaces = ""; 6891 for my $s (1 .. $pad) 6892 { 6893 $spaces .= " "; 6894 } 6895 $the_metrics[$k] = $spaces . $the_metrics[$k]; 6896 6897 my $msg = "padding spaces = $spaces the_metrics[$k] = $the_metrics[$k]"; 6898 gp_message ("debugXL", $subr_name, $msg); 6899 } 6900 6901## my $end_game = "end game3=> pad = $pad" . $hex_addresses[$k] . " " . $the_metrics[$k] . " " . $special_marker[$k] . $the_function_name[$k]; 6902## gp_message ("debugXL", $subr_name, $end_game); 6903 } 6904 6905#------------------------------------------------------------------------------ 6906# An example what @function_lines should look like after the split: 6907# <empty> 6908# 6:0x0003ad20 drand48 0.100 0.084 768240570 0 6909# 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0 6910# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 6911#------------------------------------------------------------------------------ 6912 @function_lines = split ($separator, $data_function_block); 6913 6914#------------------------------------------------------------------------------ 6915# Parse the individual lines. Replace multi-occurrence functions by their 6916# unique alternative name and mark the target function. 6917# 6918# The above split operation produces an empty first field because the line 6919# starts with the separator. This is why skip the first field. 6920#------------------------------------------------------------------------------ 6921 for my $i ($index_start .. $index_end) 6922 { 6923 my $input_line = $the_metrics[$i]; 6924 6925 gp_message ("debugXL", $subr_name, "the_metrics[$i] = ". $the_metrics[$i]); 6926 6927#------------------------------------------------------------------------------ 6928# In case the last metric is 0. only, we append 3 extra characters that 6929# represent zero. We cannot change the number to 0.000 though because that 6930# has a different interpretation than 0. 6931# In a later phase, the "ZZZ" symbol will be removed again, but for now it 6932# creates consistency in, for example, the length of the metrics part. 6933#------------------------------------------------------------------------------ 6934 if ($input_line =~ /[\w0-9$decimal_separator]*(0$decimal_separator$)/) 6935 { 6936 if (defined ($1) ) 6937 { 6938 my $decimal_point = $decimal_separator; 6939 $decimal_point =~ s/\\//; 6940 my $txt = "input_line = $input_line = ended with 0"; 6941 $txt .= $decimal_point; 6942 gp_message ("debugXL", $subr_name, $txt); 6943 6944 $the_metrics[$i] .= "ZZZ"; 6945 } 6946 } 6947 6948 $hex_address = $hex_addresses[$i]; 6949 $marker_function = $special_marker[$i]; 6950 $routine = $the_function_name[$i]; 6951#------------------------------------------------------------------------------ 6952# Get the length of the metrics line before ZZZ is replaced by spaces. 6953#------------------------------------------------------------------------------ 6954 $all_metrics = $the_metrics[$i]; 6955 $metrics_length = length ($all_metrics); 6956 $all_metrics =~ s/ZZZ/ /g; 6957 6958 $max_metrics_length = max ($max_metrics_length, $metrics_length); 6959 6960 push (@marker, $marker_function); 6961 push (@address_field, $hex_address); 6962 push (@metric_values, $all_metrics); 6963 push (@function_names, $routine); 6964 6965 my $index_into_function_info_ref = get_index_function_info ( 6966 \$routine, 6967 \$hex_addresses[$i], 6968 $function_info_ref); 6969 6970 my $index_into_function_info = ${ $index_into_function_info_ref }; 6971 $target_tag = $function_info[$index_into_function_info]{"tag_id"}; 6972 $alt_name = $function_info[$index_into_function_info]{"alt_name"}; 6973 6974#------------------------------------------------------------------------------ 6975# Keep the name of the target function (the one marked with a *) for later use. 6976# This is the tag that identifies the block in the caller-callee output. The 6977# tag is used in the link to the caller-callee in the function overview. 6978#------------------------------------------------------------------------------ 6979 if ($marker_function eq "*") 6980 { 6981 $tag_for_header = $target_tag; 6982 $name_in_header = $alt_name; 6983 6984#------------------------------------------------------------------------------ 6985# We need to replace the "<" symbol in the code by "<". 6986#------------------------------------------------------------------------------ 6987 $name_in_header =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 6988 6989 } 6990 push (@final_function_names, $alt_name); 6991 push (@function_tags, $target_tag); 6992 6993 gp_message ("debugXL", $subr_name, "index_into_function_info = $index_into_function_info"); 6994 gp_message ("debugXL", $subr_name, "target_tag = $target_tag"); 6995 gp_message ("debugXL", $subr_name, "alt_name = $alt_name"); 6996 6997 } #-- End of loop for my $i ($index_start .. $index_end) 6998 6999 my $tag_line = "<a id='" . $tag_for_header . "'></a>"; 7000 $html_line = "<br>\n"; 7001 $html_line .= $tag_line . "Function name: "; 7002 $html_line .= "<span style='color:" . $g_html_color_scheme{"target_function_name"} . "'>"; 7003 $html_line .= "<b>" . $name_in_header . "</b></span>\n"; 7004 $html_line .= "<br>"; 7005 7006 push (@html_block_prologue, $html_line); 7007 7008 gp_message ("debugXL", $subr_name, "the final function block for $name_in_header"); 7009 7010 $href_file = $g_html_base_file_name{"caller_callee"} . ".html"; 7011 7012#------------------------------------------------------------------------------ 7013# Process the function blocks and generate the HTML structure for them. 7014#------------------------------------------------------------------------------ 7015 for my $i (0 .. $#final_function_names) 7016 { 7017 $current_function_name = $final_function_names[$i]; 7018 gp_message ("debugXL", $subr_name, "current_function_name = $current_function_name"); 7019 7020#------------------------------------------------------------------------------ 7021# Do not add hyperlinks for <Total>. 7022#------------------------------------------------------------------------------ 7023 if ($current_function_name eq "<Total>") 7024 { 7025 $create_hyperlinks = $FALSE; 7026 } 7027 else 7028 { 7029 $create_hyperlinks = $TRUE; 7030 } 7031 7032#------------------------------------------------------------------------------ 7033# We need to replace the "<" symbol in the code by "<". 7034#------------------------------------------------------------------------------ 7035 $current_function_name =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 7036 7037 $html_line = $metric_values[$i] . " "; 7038 7039 if ($marker[$i] eq "*") 7040 { 7041 $current_function_name = "<b>" . $current_function_name . "</b>"; 7042 } 7043 $html_line .= " <a href='" . $href_file . "#" . $function_tags[$i] . "'>" . $current_function_name . "</a>"; 7044 7045 if ($marker[$i] eq "*") 7046 { 7047 $html_line = "<br>" . $html_line; 7048 } 7049 elsif (($marker[$i] ne "*") and ($i == 0)) 7050 { 7051 $html_line = "<br>" . $html_line; 7052 } 7053 7054 gp_message ("debugXL", $subr_name, "html_line = $html_line"); 7055 7056#------------------------------------------------------------------------------ 7057# Find the index into "function_info" for this particular function. 7058#------------------------------------------------------------------------------ 7059 $routine = $function_names[$i]; 7060 $current_address = $address_field[$i]; 7061 7062 my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info); 7063 my $target_index = ${ $target_index_ref }; 7064 7065 gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address target_index = $target_index"); 7066 7067#------------------------------------------------------------------------------ 7068# TBD Do this once for each function and store the result. This is a saving 7069# because functions may and typically will appear more than once. 7070#------------------------------------------------------------------------------ 7071 my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"}; 7072 7073#------------------------------------------------------------------------------ 7074# Add the links to the line. Make sure there is at least one space. 7075#------------------------------------------------------------------------------ 7076 my $spaces = " "; 7077 for my $k (1 .. $spaces_left) 7078 { 7079 $spaces .= " "; 7080 } 7081 7082 if ($create_hyperlinks) 7083 { 7084 $html_line .= $spaces; 7085 $html_line .= $function_info[$target_index]{"href_source"}; 7086 $html_line .= " "; 7087 $html_line .= $function_info[$target_index]{"href_disassembly"}; 7088 } 7089 7090 push (@html_code_function_block, $html_line); 7091 } 7092 7093 for my $lines (0 .. $#html_code_function_block) 7094 { 7095 gp_message ("debugXL", $subr_name, "final html block = " . $html_code_function_block[$lines]); 7096 } 7097 7098 return (\@html_block_prologue, \@html_code_function_block); 7099 7100} #-- End of subroutine generate_html_function_blocks 7101 7102#------------------------------------------------------------------------------ 7103# Generate the index.html file. 7104#------------------------------------------------------------------------------ 7105sub generate_index 7106{ 7107 my $subr_name = get_my_name (); 7108 7109 my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref, 7110 $number_of_metrics_ref, $function_info_ref, $function_address_info_ref, 7111 $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref, 7112 $metric_description_reversed_ref, $number_of_warnings_ref, 7113 $table_execution_stats_ref) = @_; 7114 7115 my $outputdir = ${ $outputdir_ref }; 7116 my $html_first_metric_file = ${ $html_first_metric_file_ref }; 7117 my $summary_metrics = ${ $summary_metrics_ref }; 7118 my $number_of_metrics = ${ $number_of_metrics_ref }; 7119 my @function_info = @{ $function_info_ref }; 7120 my %function_address_info = %{ $function_address_info_ref }; 7121 my @sort_fields = @{ $sort_fields_ref }; 7122 my @exp_dir_list = @{ $exp_dir_list_ref }; 7123 my %addressobjtextm = %{ $addressobjtextm_ref }; 7124 my %metric_description_reversed = %{ $metric_description_reversed_ref }; 7125 my $number_of_warnings = ${ $number_of_warnings_ref }; 7126 my @table_execution_stats = @{ $table_execution_stats_ref }; 7127 7128 my @file_contents = (); 7129 7130 my $acknowledgement; 7131 my @abs_path_exp_dirs = (); 7132 my $input_experiments; 7133 my $target_function; 7134 my $html_line; 7135 my $ftag; 7136 my $max_length = 0; 7137 my %html_source_functions = (); 7138 my $html_header; 7139 my @experiment_directories = (); 7140 my $html_acknowledgement; 7141 my $html_file_title; 7142 my $html_output_file; 7143 my $html_function_view; 7144 my $html_caller_callee_view; 7145 my $html_experiment_info; 7146 my $html_warnings_page; 7147 my $href_link; 7148 my $file_title; 7149 my $html_gprofng; 7150 my $html_end; 7151 my $max_length_metrics; 7152 my $page_title; 7153 my $size_text; 7154 my $position_text; 7155 7156 my $ln; 7157 my $base; 7158 my $base_index_page; 7159 my $infile; 7160 my $outfile; 7161 my $rec; 7162 my $skip; 7163 my $callsize; 7164 my $dest; 7165 my $final_string; 7166 my @headers; 7167 my $header; 7168 my $sort_index; 7169 my $pc_address; 7170 my $anchor; 7171 my $directory_name; 7172 my $f2; 7173 my $f3; 7174 my $file; 7175 my $sline; 7176 my $src; 7177 my $srcfile_name; 7178 my $tmp1; 7179 my $tmp2; 7180 my $fullsize; 7181 my $regf2; 7182 my $trimsize; 7183 my $EIL; 7184 my $EEIL; 7185 my $AOBJ; 7186 my $RI; 7187 my $HDR; 7188 my $CALLER_CALLEE; 7189 my $NAME; 7190 my $SRC; 7191 my $TRIMMED; 7192 7193#------------------------------------------------------------------------------ 7194# Add a forward slash to make it easier when creating file names. 7195#------------------------------------------------------------------------------ 7196 $outputdir = append_forward_slash ($outputdir); 7197 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 7198 7199 my $LANG = $g_locale_settings{"LANG"}; 7200 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 7201 7202 $input_experiments = join (", ", @exp_dir_list); 7203 7204 for my $i (0 .. $#exp_dir_list) 7205 { 7206 my $dir = get_basename ($exp_dir_list[$i]); 7207 push @abs_path_exp_dirs, $dir; 7208 } 7209 $input_experiments = join (", ", @abs_path_exp_dirs); 7210 7211 gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); 7212 7213#------------------------------------------------------------------------------ 7214# TBD: Pass in the values for $expr_name and $cmd 7215#------------------------------------------------------------------------------ 7216 $html_file_title = "Main index page"; 7217 7218 @experiment_directories = split (",", $input_experiments); 7219 $html_acknowledgement = ${ create_html_credits () }; 7220 7221 $html_end = ${ terminate_html_document () }; 7222 7223 $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html"; 7224 7225 open (INDEX, ">", $html_output_file) 7226 or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); 7227 gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); 7228 7229 $page_title = "GPROFNG Performance Analysis"; 7230 $size_text = "h1"; 7231 $position_text = "center"; 7232 $html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 7233 7234 $html_header = ${ create_html_header (\$html_file_title) }; 7235 7236 print INDEX $html_header; 7237 print INDEX $html_gprofng; 7238 print INDEX "$_" for @g_html_experiment_stats; 7239 print INDEX "$_" for @table_execution_stats; 7240 7241 $html_experiment_info = "<a href=\'"; 7242 $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html"; 7243 $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n"; 7244 7245 $html_warnings_page = "<a href=\'"; 7246 $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html"; 7247 $html_warnings_page .= "\'><h3>Warnings (" . $number_of_warnings . ")</h3></a>\n"; 7248 7249 $html_function_view = "<a href=\'"; 7250 $html_function_view .= $html_first_metric_file; 7251 $html_function_view .= "\'><h3>Function View</h3></a>\n"; 7252 7253 $html_caller_callee_view = "<a href=\'"; 7254 $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html"; 7255 $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n"; 7256 7257 print INDEX "<br>\n"; 7258## print INDEX "<b>\n"; 7259 print INDEX $html_experiment_info; 7260 print INDEX $html_warnings_page;; 7261## print INDEX "<br>\n"; 7262## print INDEX "<br>\n"; 7263 print INDEX $html_function_view; 7264## print INDEX "<br>\n"; 7265## print INDEX "<br>\n"; 7266 print INDEX $html_caller_callee_view; 7267## print INDEX "</b>\n"; 7268## print INDEX "<br>\n"; 7269## print INDEX "<br>\n"; 7270 7271 print INDEX $html_acknowledgement; 7272 print INDEX $html_end; 7273 7274 close (INDEX); 7275 7276 gp_message ("debug", $subr_name, "closed file $html_output_file"); 7277 7278 return (0); 7279 7280} #-- End of subroutine generate_index 7281 7282#------------------------------------------------------------------------------ 7283# Get all the metrics available 7284# 7285# (gp-display-text) metric_list 7286# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name 7287# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 7288# Available metrics: 7289# Exclusive Total CPU Time: e.%totalcpu 7290# Inclusive Total CPU Time: i.%totalcpu 7291# Exclusive CPU Cycles: e.+%cycles 7292# Inclusive CPU Cycles: i.+%cycles 7293# Exclusive Instructions Executed: e+%insts 7294# Inclusive Instructions Executed: i+%insts 7295# Exclusive Last-Level Cache Misses: e+%llm 7296# Inclusive Last-Level Cache Misses: i+%llm 7297# Exclusive Instructions Per Cycle: e+IPC 7298# Inclusive Instructions Per Cycle: i+IPC 7299# Exclusive Cycles Per Instruction: e+CPI 7300# Inclusive Cycles Per Instruction: i+CPI 7301# Size: size 7302# PC Address: address 7303# Name: name 7304#------------------------------------------------------------------------------ 7305sub get_all_the_metrics 7306{ 7307 my $subr_name = get_my_name (); 7308 7309 my ($experiments_ref, $outputdir_ref) = @_; 7310 7311 my $experiments = ${ $experiments_ref }; 7312 my $outputdir = ${ $outputdir_ref }; 7313 7314 my $ignore_value; 7315 my $gp_functions_cmd; 7316 my $gp_display_text_cmd; 7317 7318 my $metrics_output_file = $outputdir . "metrics-all"; 7319 my $result_file = $outputdir . $g_gp_output_file; 7320 my $gp_error_file = $outputdir . $g_gp_error_logfile; 7321 my $script_file_metrics = $outputdir . "script-metrics"; 7322 7323 my @metrics_data = (); 7324 7325 open (SCRIPT_METRICS, ">", $script_file_metrics) 7326 or die ("$subr_name - unable to open script file $script_file_metrics for writing: '$!'"); 7327 gp_message ("debug", $subr_name, "opened script file $script_file_metrics for writing"); 7328 7329 print SCRIPT_METRICS "# outfile $metrics_output_file\n"; 7330 print SCRIPT_METRICS "outfile $metrics_output_file\n"; 7331 print SCRIPT_METRICS "# metric_list\n"; 7332 print SCRIPT_METRICS "metric_list\n"; 7333 7334 close (SCRIPT_METRICS); 7335 7336 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file_metrics $experiments"; 7337 7338 gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get all the metrics"); 7339 7340 $gp_display_text_cmd = "$gp_functions_cmd 1>> $result_file 2>> $gp_error_file"; 7341 gp_message ("debug", $subr_name, "cmd = $gp_display_text_cmd"); 7342 7343 my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 7344 7345 if ($error_code != 0) 7346 { 7347 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 7348 $error_code, 7349 $gp_error_file); 7350 gp_message ("abort", $subr_name, "execution terminated"); 7351 } 7352 7353 open (METRICS_INFO, "<", $metrics_output_file) 7354 or die ("$subr_name - unable to open file $metrics_output_file for reading '$!'"); 7355 gp_message ("debug", $subr_name, "opened file $metrics_output_file for reading"); 7356 7357#------------------------------------------------------------------------------ 7358# Read the input file into memory. 7359#------------------------------------------------------------------------------ 7360 chomp (@metrics_data = <METRICS_INFO>); 7361 gp_message ("debug", $subr_name, "read all contents of file $metrics_output_file into memory"); 7362 gp_message ("debug", $subr_name, "\$#metrics_data = $#metrics_data"); 7363 7364 my $input_line; 7365 my $ignore_lines_regex = '^(?:Current|Available|\s+Size:|\s+PC Address:|\s+Name:)'; 7366 my $split_line_regex = '(.*): (.*)'; 7367 my $empty_line_regex = '^\s*$'; 7368 my @metric_list_all = (); 7369 for (my $line_no=0; $line_no <= $#metrics_data; $line_no++) 7370 { 7371 7372 $input_line = $metrics_data[$line_no]; 7373 7374## if ( not (($input_line =~ /$ignore_lines_regex/ or ($input_line =~ /^\s*$/)))) 7375 if ( not ($input_line =~ /$ignore_lines_regex/) and not ($input_line =~ /$empty_line_regex/) ) 7376 { 7377 if ($input_line =~ /$split_line_regex/) 7378 { 7379#------------------------------------------------------------------------------ 7380# Remove the percentages. 7381#------------------------------------------------------------------------------ 7382 my $metric_definition = $2; 7383 $metric_definition =~ s/\%//g; 7384 gp_message ("debug", $subr_name, "line_no = $line_no $metrics_data[$line_no] metric_definition = $metric_definition"); 7385 push (@metric_list_all, $metric_definition); 7386 } 7387 } 7388 7389 } 7390 7391 gp_message ("debug", $subr_name, "\@metric_list_all = @metric_list_all"); 7392 7393 my $final_list = join (":", @metric_list_all); 7394 gp_message ("debug", $subr_name, "final_list = $final_list"); 7395 7396 close (METRICS_INFO); 7397 7398 return (\$final_list); 7399 7400} #-- End of subroutine get_all_the_metrics 7401 7402#------------------------------------------------------------------------------ 7403# A simple function to return the basename using fileparse. To keep things 7404# simple, a suffixlist is not supported. In case this is needed, use the 7405# fileparse function directly. 7406#------------------------------------------------------------------------------ 7407sub get_basename 7408{ 7409 my ($full_name) = @_; 7410 7411 my $ignore_value_1; 7412 my $ignore_value_2; 7413 my $basename_value; 7414 7415 ($basename_value, $ignore_value_1, $ignore_value_2) = fileparse ($full_name); 7416 7417 return ($basename_value); 7418 7419} #-- End of subroutine get_basename 7420 7421#------------------------------------------------------------------------------ 7422# Get the details on the experiments and store these in a file. Each 7423# experiment has its own file. This makes the processing easier. 7424#------------------------------------------------------------------------------ 7425sub get_experiment_info 7426{ 7427 my $subr_name = get_my_name (); 7428 7429 my ($outputdir_ref, $exp_dir_list_ref) = @_; 7430 7431 my $outputdir = ${ $outputdir_ref }; 7432 my @exp_dir_list = @{ $exp_dir_list_ref }; 7433 7434 my $cmd_output; 7435 my $current_slot; 7436 my $error_code; 7437 my $exp_info_file; 7438 my @exp_info = (); 7439 my @experiment_data = (); 7440 my $gp_error_file; 7441 my $gp_display_text_cmd; 7442 my $gp_functions_cmd; 7443 my $gp_log_file; 7444 my $ignore_value; 7445 my $overview_file; 7446 my $result_file; 7447 my $script_file; 7448 my $the_experiments; 7449 7450 $the_experiments = join (" ", @exp_dir_list); 7451 7452 $script_file = $outputdir . "gp-info-exp.script"; 7453 $exp_info_file = $outputdir . "gp-info-exp-list.out"; 7454 $overview_file = $outputdir . "gp-overview.out"; 7455 $gp_log_file = $outputdir . $g_gp_output_file; 7456 $gp_error_file = $outputdir . $g_gp_error_logfile; 7457 7458 open (SCRIPT_EXPERIMENT_INFO, ">", $script_file) 7459 or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); 7460 gp_message ("debug", $subr_name, "opened script file $script_file for writing"); 7461 7462#------------------------------------------------------------------------------ 7463# Attributed User CPU Time=a.user : for calltree - see P37 in manual 7464#------------------------------------------------------------------------------ 7465 print SCRIPT_EXPERIMENT_INFO "# compare on\n"; 7466 print SCRIPT_EXPERIMENT_INFO "compare on\n"; 7467 print SCRIPT_EXPERIMENT_INFO "# outfile $exp_info_file\n"; 7468 print SCRIPT_EXPERIMENT_INFO "outfile $exp_info_file\n"; 7469 print SCRIPT_EXPERIMENT_INFO "# exp_list\n"; 7470 print SCRIPT_EXPERIMENT_INFO "exp_list\n"; 7471 print SCRIPT_EXPERIMENT_INFO "# outfile $overview_file\n"; 7472 print SCRIPT_EXPERIMENT_INFO "outfile $overview_file\n"; 7473 print SCRIPT_EXPERIMENT_INFO "# overview\n"; 7474 print SCRIPT_EXPERIMENT_INFO "overview\n"; 7475 7476 close SCRIPT_EXPERIMENT_INFO; 7477 7478 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments"; 7479 7480 gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment information"); 7481 7482 $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file"; 7483 7484 ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 7485 7486 if ($error_code != 0) 7487 { 7488 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 7489 $error_code, 7490 $gp_error_file); 7491 gp_message ("abort", $subr_name, "execution terminated"); 7492 } 7493 7494#------------------------------------------------------------------------------- 7495# The first file has the following format: 7496# 7497# ID Sel PID Experiment 7498# == === ======= ====================================================== 7499# 1 yes 2078714 <absolute_path/mxv.hwc.1.thr.er 7500# 2 yes 2078719 <absolute_path/mxv.hwc.2.thr.er 7501#------------------------------------------------------------------------------- 7502 open (EXP_INFO, "<", $exp_info_file) 7503 or die ("$subr_name - unable to open file $exp_info_file for reading '$!'"); 7504 gp_message ("debug", $subr_name, "opened script file $exp_info_file for reading"); 7505 7506 chomp (@exp_info = <EXP_INFO>); 7507 7508#------------------------------------------------------------------------------- 7509# TBD - Check for the groups to exist below: 7510#------------------------------------------------------------------------------- 7511 $current_slot = 0; 7512 for my $i (0 .. $#exp_info) 7513 { 7514 my $input_line = $exp_info[$i]; 7515 7516 gp_message ("debug", $subr_name, "$i => exp_info[$i] = $exp_info[$i]"); 7517 7518 if ($input_line =~ /^\s*(\d+)\s+(.+)/) 7519 { 7520 my $exp_id = $1; 7521 my $remainder = $2; 7522 $experiment_data[$current_slot]{"exp_id"} = $exp_id; 7523 $experiment_data[$current_slot]{"exp_data_file"} = $outputdir . "gp-info-exp-" . $exp_id . ".out"; 7524 gp_message ("debug", $subr_name, $i . " " . $exp_id . " " . $remainder); 7525 if ($remainder =~ /^(\w+)\s+(\d+)\s+(.+)/) 7526 { 7527 my $exp_name = $3; 7528 $experiment_data[$current_slot]{"exp_name_full"} = $exp_name; 7529 $experiment_data[$current_slot]{"exp_name_short"} = get_basename ($exp_name); 7530 $current_slot++; 7531 gp_message ("debug", $subr_name, $i . " " . $1 . " " . $2 . " " . $3); 7532 } 7533 else 7534 { 7535 my $msg = "remainder = $remainder has an unexpected format"; 7536 gp_message ("assertion", $subr_name, $msg); 7537 } 7538 } 7539 } 7540#------------------------------------------------------------------------------- 7541# The experiment IDs and names are known. We can now generate the info for 7542# each individual experiment. 7543#------------------------------------------------------------------------------- 7544 $gp_log_file = $outputdir . $g_gp_output_file; 7545 $gp_error_file = $outputdir . $g_gp_error_logfile; 7546 7547 $script_file = $outputdir . "gp-details-exp.script"; 7548 7549 open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file) 7550 or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); 7551 gp_message ("debug", $subr_name, "opened script file $script_file for writing"); 7552 7553 for my $i (sort keys @experiment_data) 7554 { 7555 my $exp_id = $experiment_data[$i]{"exp_id"}; 7556 7557 $result_file = $experiment_data[$i]{"exp_data_file"}; 7558 7559# statistics 7560# header 7561 print SCRIPT_EXPERIMENT_DETAILS "# outfile " . $result_file . "\n"; 7562 print SCRIPT_EXPERIMENT_DETAILS "outfile " . $result_file . "\n"; 7563 print SCRIPT_EXPERIMENT_DETAILS "# header " . $exp_id . "\n"; 7564 print SCRIPT_EXPERIMENT_DETAILS "header " . $exp_id . "\n"; 7565 print SCRIPT_EXPERIMENT_DETAILS "# statistics " . $exp_id . "\n"; 7566 print SCRIPT_EXPERIMENT_DETAILS "statistics " . $exp_id . "\n"; 7567 7568 } 7569 7570 close (SCRIPT_EXPERIMENT_DETAILS); 7571 7572 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments"; 7573 7574 gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment details"); 7575 7576 $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file"; 7577 7578 ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 7579 7580 if ($error_code != 0) 7581#------------------------------------------------------------------------------- 7582# This is unlikely to happen, but you never know. 7583#------------------------------------------------------------------------------- 7584 { 7585 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 7586 $error_code, 7587 $gp_error_file); 7588 gp_message ("abort", $subr_name, "execution terminated"); 7589 } 7590 7591 return (\@experiment_data); 7592 7593} #-- End of subroutine get_experiment_info 7594 7595#------------------------------------------------------------------------------ 7596# This subroutine returns a string of the type "size=<n>", where <n> is the 7597# size of the file passed in. If n > 1024, a unit is appended. 7598#------------------------------------------------------------------------------ 7599sub getfilesize 7600{ 7601 my $subr_name = get_my_name (); 7602 7603 my ($filename) = @_; 7604 7605 my $size; 7606 my $file_stat; 7607 7608 if (not -e $filename) 7609 { 7610#------------------------------------------------------------------------------ 7611# The return value is used in the caller. This is why we return the empty 7612# string in case the file does not exist. 7613#------------------------------------------------------------------------------ 7614 gp_message ("debug", $subr_name, "filename = $filename not found"); 7615 return (""); 7616 } 7617 else 7618 { 7619 $file_stat = stat ($filename); 7620 $size = $file_stat->size; 7621 7622 gp_message ("debug", $subr_name, "filename = $filename"); 7623 gp_message ("debug", $subr_name, "size = $size"); 7624 7625 if ($size > 1024) 7626 { 7627 if ($size > 1024*1024) 7628 { 7629 $size = $size/1024/1024; 7630 $size =~ s/\..*//; 7631 $size = $size."MB"; 7632 } 7633 else 7634 { 7635 $size = $size/1024; 7636 $size =~ s/\..*//; 7637 $size = $size."KB"; 7638 } 7639 } 7640 else 7641 { 7642 $size=$size." bytes"; 7643 } 7644 gp_message ("debug", $subr_name, "size = $size title=\"$size\""); 7645 7646 return ("title=\"$size\""); 7647 } 7648 7649} #-- End of subroutine getfilesize 7650 7651#------------------------------------------------------------------------------ 7652# Parse the fsummary output and for all functions, store all the information 7653# found in "function_info". In addition to this, several derived structures 7654# are stored as well, making this structure a "onestop" place to get all the 7655# info that is needed. 7656#------------------------------------------------------------------------------ 7657sub get_function_info 7658{ 7659 my $subr_name = get_my_name (); 7660 7661 my ($FSUMMARY_FILE) = @_; 7662 7663#------------------------------------------------------------------------------ 7664# The regex section. 7665#------------------------------------------------------------------------------ 7666 my $white_space_regex = '\s*'; 7667 7668 my @function_info = (); 7669 my %function_address_and_index = (); 7670 my %LINUX_vDSO = (); 7671 my %function_view_structure = (); 7672 my %addressobjtextm = (); 7673#------------------------------------------------------------------------------ 7674# TBD: This structure is no longer used and most likely can be removed. 7675#------------------------------------------------------------------------------ 7676 my %functions_index = (); 7677 7678# TBD: check 7679 my $full_address_field; 7680 my %source_files = (); 7681 7682 my $i; 7683 my $line; 7684 my $routine_flag; 7685 my $value; 7686 my $whatever; 7687 my $df_flag; 7688 my $address_decimal; 7689 my $routine; 7690 7691 my $num_source_files = 0; 7692 my $number_of_functions = 0; 7693 my $number_of_unique_functions = 0; 7694 my $number_of_non_unique_functions = 0; 7695 7696#------------------------------------------------------------------------------ 7697# Open the file generated using the -fsummary option. 7698#------------------------------------------------------------------------------ 7699 open (FSUMMARY_FILE, "<", $FSUMMARY_FILE) 7700 or die ("$subr_name - unable to open $FSUMMARY_FILE for reading: '$!'"); 7701 gp_message ("debug", $subr_name, "opened file $FSUMMARY_FILE for reading"); 7702 7703#------------------------------------------------------------------------------ 7704# This is the typical structure of the fsummary output: 7705# 7706# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 7707# Functions sorted by metric: Exclusive Total CPU Time 7708# 7709# <Total> 7710# Exclusive Total CPU Time: 11.538 (100.0%) 7711# Inclusive Total CPU Time: 11.538 (100.0%) 7712# Size: 0 7713# PC Address: 1:0x00000000 7714# Source File: (unknown) 7715# Object File: (unknown) 7716# Load Object: <Total> 7717# Mangled Name: 7718# Aliases: 7719# 7720# a_function_name 7721# Exclusive Total CPU Time: 4.003 ( 34.7%) 7722# Inclusive Total CPU Time: 4.003 ( 34.7%) 7723# Size: 715 7724# PC Address: 2:0x00006c61 7725# Source File: <absolute path to source file> 7726# Object File: <object filename> 7727# Load Object: <executable name> 7728# Mangled Name: 7729# Aliases: 7730# 7731# The previous block is repeated for every function. 7732#------------------------------------------------------------------------------ 7733 7734#------------------------------------------------------------------------------ 7735# Skip the header. The header is defined to end with a blank line. 7736#------------------------------------------------------------------------------ 7737 while (<FSUMMARY_FILE>) 7738 { 7739 $line = $_; 7740 chomp ($line); 7741 if ($line =~ /^\s*$/) 7742 { 7743 last; 7744 } 7745 } 7746 7747#------------------------------------------------------------------------------ 7748# Process the remaining blocks. Note that the first line should be <Total>, 7749# but this is currently not checked. 7750#------------------------------------------------------------------------------ 7751 $i = 0; 7752 $routine_flag = $TRUE; 7753 while (<FSUMMARY_FILE>) 7754 { 7755 $line = $_; 7756 chomp ($line); 7757 gp_message ("debugXL", $subr_name, "line = $line"); 7758 7759 if ($line =~ /^\s*$/) 7760#------------------------------------------------------------------------------ 7761# Blank line. 7762#------------------------------------------------------------------------------ 7763 { 7764 $routine_flag = $TRUE; 7765 $df_flag = 0; 7766 7767#------------------------------------------------------------------------------ 7768# Linux vDSO exception 7769# 7770# TBD: Check if still relevant. 7771#------------------------------------------------------------------------------ 7772 if ($function_info[$i]{"Load Object"} eq "DYNAMIC_FUNCTIONS") 7773 { 7774 $LINUX_vDSO{substr ($function_info[$i]{"addressobjtext"},1)} = $function_info[$i]{"routine"}; 7775 } 7776 $i++; 7777 next; 7778 } 7779 7780 if ($routine_flag) 7781#------------------------------------------------------------------------------ 7782# Should be the first line after the blank line. 7783#------------------------------------------------------------------------------ 7784 { 7785 $routine = $line; 7786 push (@{ $g_map_function_to_index{$routine} }, $i); 7787 gp_message ("debugXL", $subr_name, "pushed i = $i to g_map_function_to_index{$routine}"); 7788 7789#------------------------------------------------------------------------------ 7790# In a later parsing phase we need to know how many fields there are in a 7791# function name. For example, "<static>@0x21850 (<libc-2.28.so>)" is name that 7792# may show up in a function list. 7793# 7794# Here we determine the number of fields and store it. 7795#------------------------------------------------------------------------------ 7796 my @fields_in_name = split (" ", $routine); 7797 $function_info[$i]{"fields in routine name"} = scalar (@fields_in_name); 7798 7799#------------------------------------------------------------------------------ 7800# This name may change if the function has multiple occurrences, but in any 7801# case, at the end of this routine this component has the final name to be 7802# used. 7803#------------------------------------------------------------------------------ 7804 $function_info[$i]{"alt_name"} = $routine; 7805 if (not exists ($g_function_occurrences{$routine})) 7806 { 7807 gp_message ("debugXL", $subr_name, "the entry in function_info for $routine does not exist"); 7808 $function_info[$i]{"routine"} = $routine; 7809 $g_function_occurrences{$routine} = 1; 7810 7811 gp_message ("debugXL", $subr_name, "g_function_occurrences{$routine} = $g_function_occurrences{$routine}"); 7812 } 7813 else 7814 { 7815 gp_message ("debugXL", $subr_name, "the entry in function_info for $routine exists already"); 7816 $function_info[$i]{"routine"} = $routine; 7817 $g_function_occurrences{$routine} += 1; 7818 if (not exists ($g_multi_count_function{$routine})) 7819 { 7820 $g_multi_count_function{$routine} = $TRUE; 7821 } 7822 my $msg = "g_function_occurrences{$routine} = " . 7823 $g_function_occurrences{$routine}; 7824 gp_message ("debugXL", $subr_name, $msg); 7825 } 7826#------------------------------------------------------------------------------ 7827# New: used when generating the index. 7828#------------------------------------------------------------------------------ 7829 $function_info[$i]{"function length"} = length ($routine); 7830 $function_info[$i]{"tag_id"} = create_function_tag ($i); 7831 if (not exists ($g_function_tag_id{$routine})) 7832 { 7833 $g_function_tag_id{$routine} = create_function_tag ($i); 7834 } 7835 else 7836 { 7837 7838#------------------------------------------------------------------------------ 7839## TBD HACK!!! CHECK!!!!! 7840#------------------------------------------------------------------------------ 7841 $g_function_tag_id{$routine} = $i; 7842 } 7843 7844 $routine_flag = $FALSE; 7845 gp_message ("debugXL", $subr_name, "stored " . $function_info[$i]{"routine"}); 7846 7847#------------------------------------------------------------------------------ 7848# The $functions_index hash contains an array. After an initial assignment, 7849# other values that have been found are pushed onto the arrays. 7850#------------------------------------------------------------------------------ 7851 if (not exists ($functions_index{$routine})) 7852 { 7853 $functions_index{$routine} = [$i]; 7854 } 7855 else 7856 { 7857#------------------------------------------------------------------------------ 7858# Add the array index to the list 7859#------------------------------------------------------------------------------ 7860 push (@{$functions_index{$routine}}, $i); 7861 } 7862 next; 7863 } 7864 7865#------------------------------------------------------------------------------ 7866# Expected format of an input line: 7867# Exclusive Total CPU Time: 4.003 ( 34.7%) 7868# or: 7869# Source File: <absolute_path>/name_of_source_file 7870#------------------------------------------------------------------------------ 7871 $line =~ s/^\s+//; 7872 7873 my @input_fields = split (":", $line); 7874 my $no_of_elements = scalar (@input_fields); 7875 7876 gp_message ("debugXL", $subr_name, "#input_fields = $#input_fields"); 7877 gp_message ("debugXL", $subr_name, "no_of_elements = $no_of_elements"); 7878 gp_message ("debugXL", $subr_name, "input_fields[0] = $input_fields[0]"); 7879 7880 if ($no_of_elements == 1) 7881 { 7882 $whatever = $input_fields[0]; 7883 $value = ""; 7884 } 7885 elsif ($no_of_elements == 2) 7886 { 7887#------------------------------------------------------------------------------ 7888# Note that value may consist of multiple fields (e.g. 1.651 ( 95.4%)). 7889#------------------------------------------------------------------------------ 7890 $whatever = $input_fields[0]; 7891 $value = $input_fields[1]; 7892 } 7893 elsif ($no_of_elements == 3) 7894 { 7895#------------------------------------------------------------------------------ 7896# Assumption: must be an address field. Restore the second colon. 7897#------------------------------------------------------------------------------ 7898 $whatever = $input_fields[0]; 7899 $value = $input_fields[1] . ":" . $input_fields[2]; 7900 } 7901 else 7902 { 7903 my $msg = "unexpected: number of fields = " . $no_of_elements; 7904 gp_message ("assertion", $subr_name, $msg); 7905 } 7906#------------------------------------------------------------------------------ 7907# Remove any leading whitespace characters. 7908#------------------------------------------------------------------------------ 7909 $value =~ s/$white_space_regex//; 7910 7911 gp_message ("debugXL", $subr_name, "whatever = $whatever value = $value"); 7912 7913 $function_info[$i]{$whatever} = $value; 7914 7915#------------------------------------------------------------------------------ 7916# TBD: Seems to be not used anymore and can most likely be removed. Check this. 7917#------------------------------------------------------------------------------ 7918 if ($whatever =~ /Source File/) 7919 { 7920 if (!exists ($source_files{$value})) 7921 { 7922 $source_files{$value} = $TRUE; 7923 $num_source_files++; 7924 } 7925 } 7926 7927 if ($whatever =~ /PC Address/) 7928 { 7929 my $segment; 7930 my $offset; 7931#------------------------------------------------------------------------------ 7932# The format of the address is assumed to be the following 2:0x000070a8 7933# Note that the regex is pretty wide. This is from the original code and 7934# could be made more specific: 7935# if ($value =~ /\s*(\S+):(\S+)/) 7936#------------------------------------------------------------------------------ 7937# if ($value =~ /\s*(\S+):(\S+)/) 7938 if ($value =~ /\s*(\d+):0x([0-9a-zA-Z]+)/) 7939 { 7940 $segment = $1; 7941 $offset = $2; 7942#------------------------------------------------------------------------------ 7943# Convert to a base 10 number 7944#------------------------------------------------------------------------------ 7945 $address_decimal = bigint::hex ($offset); # decimal 7946#------------------------------------------------------------------------------ 7947# Construct the address field. Note that we use the hex address here. 7948#------------------------------------------------------------------------------ 7949 $full_address_field = '@'.$segment.":0x".$offset; # e.g. @2:0x0003f280 7950 7951 $function_info[$i]{"addressobj"} = $address_decimal; 7952 $function_info[$i]{"addressobjtext"} = $full_address_field; 7953 $addressobjtextm{$full_address_field} = $i; # $RI 7954 } 7955 if (not exists ($function_address_and_index{$routine}{$value})) 7956 { 7957 $function_address_and_index{$routine}{$value} = $i; 7958 7959 my $msg = "function_address_and_index{$routine}{$value} = " . 7960 $function_address_and_index{$routine}{$value}; 7961 gp_message ("debugXL", $subr_name, $msg); 7962 } 7963 else 7964 { 7965 gp_message ("debugXL", $subr_name, "function_info: $FSUMMARY_FILE: function $routine already has a PC Address"); 7966 } 7967 7968 $number_of_functions++; 7969 } 7970 } 7971 close (FSUMMARY_FILE); 7972 7973#------------------------------------------------------------------------------ 7974# For every function in the function overview, set up an html structure with 7975# the various hyperlinks. 7976#------------------------------------------------------------------------------ 7977 gp_message ("debugXL", $subr_name, "augment function_info with alt_name"); 7978 my $target_function; 7979 my $html_line; 7980 my $ftag; 7981 my $routine_length; 7982 my %html_source_functions = (); 7983 for my $i (keys @function_info) 7984 { 7985 $target_function = $function_info[$i]{"routine"}; 7986 7987 gp_message ("debugXL", $subr_name, "i = $i target_function = $target_function"); 7988 7989 my $href_link; 7990## $href_link = "<a href=\'file." . $i . ".src.new.html#"; 7991 $href_link = "<a href=\'file." . $i . "."; 7992 $href_link .= $g_html_base_file_name{"source"}; 7993 $href_link .= ".html#"; 7994 $href_link .= $function_info[$i]{"tag_id"}; 7995 $href_link .= "\'>source</a>"; 7996 $function_info[$i]{"href_source"} = $href_link; 7997 7998 $href_link = "<a href=\'file." . $i . "."; 7999 $href_link .= $g_html_base_file_name{"disassembly"}; 8000 $href_link .= ".html#"; 8001 $href_link .= $function_info[$i]{"tag_id"}; 8002 $href_link .= "\'>disassembly</a>"; 8003 $function_info[$i]{"href_disassembly"} = $href_link; 8004 8005 $href_link = "<a href=\'"; 8006 $href_link .= $g_html_base_file_name{"caller_callee"}; 8007 $href_link .= ".html#"; 8008 $href_link .= $function_info[$i]{"tag_id"}; 8009 $href_link .= "\'>caller-callee</a>"; 8010 $function_info[$i]{"href_caller_callee"} = $href_link; 8011 8012 gp_message ("debug", $subr_name, "g_function_occurrences{$target_function} = $g_function_occurrences{$target_function}"); 8013 8014 if ($g_function_occurrences{$target_function} > 1) 8015 { 8016#------------------------------------------------------------------------------ 8017# In case a function occurs more than one time in the function overview, we 8018# add the load object and address offset info to make it unique. 8019# 8020# This forces us to update some entries in function_info too. 8021#------------------------------------------------------------------------------ 8022 my $loadobj = $function_info[$i]{"Load Object"}; 8023 my $address_field = $function_info[$i]{"addressobjtext"}; 8024 my $address_offset; 8025 8026#------------------------------------------------------------------------------ 8027# The address field has the following format: @<n>:<address_offset> 8028# We only care about the address offset. 8029#------------------------------------------------------------------------------ 8030 if ($address_field =~ /(^@\d*:*)(.+)/) 8031 { 8032 $address_offset = $2; 8033 } 8034 else 8035 { 8036 my $msg = "failed to extract the address offset from $address_field - use the full field"; 8037 gp_message ("warning", $subr_name, $msg); 8038 $address_offset = $address_field; 8039 } 8040 my $exe = get_basename ($loadobj); 8041 my $extra_field = " (<" . $exe . " $address_offset" .">)"; 8042### $target_function .= $extra_field; 8043 $function_info[$i]{"alt_name"} = $target_function . $extra_field; 8044 gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"}); 8045 8046#------------------------------------------------------------------------------ 8047# Store the length of the function name and get the tag id. 8048#------------------------------------------------------------------------------ 8049 $function_info[$i]{"function length"} = length ($target_function . $extra_field); 8050 $function_info[$i]{"tag_id"} = create_function_tag ($i); 8051 8052 gp_message ("debugXL", $subr_name, "updated function_info[$i]{'routine'} = $function_info[$i]{'routine'}"); 8053 gp_message ("debugXL", $subr_name, "updated function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}"); 8054 gp_message ("debugXL", $subr_name, "updated function_info[$i]{'function length'} = $function_info[$i]{'function length'}"); 8055 gp_message ("debugXL", $subr_name, "updated function_info[$i]{'tag_id'} = $function_info[$i]{'tag_id'}"); 8056 } 8057 } 8058 gp_message ("debug", $subr_name, "augment function_info with alt_name completed"); 8059 8060#------------------------------------------------------------------------------ 8061# Compute the maximum function name length. 8062# 8063# The maximum length is stored in %function_view_structure. 8064#------------------------------------------------------------------------------ 8065 my $max_function_length = 0; 8066 for my $i (0 .. $#function_info) 8067 { 8068 $max_function_length = max ($max_function_length, $function_info[$i]{"function length"}); 8069 8070 gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"}); 8071 } 8072 8073#------------------------------------------------------------------------------ 8074# Define the name of the table and take the length into account, since it may 8075# be longer than the function name(s). 8076#------------------------------------------------------------------------------ 8077 $function_view_structure{"table name"} = "Function name"; 8078 8079 $max_function_length = max ($max_function_length, length ($function_view_structure{"table name"})); 8080 8081 $function_view_structure{"max function length"} = $max_function_length; 8082 8083#------------------------------------------------------------------------------ 8084# Core loop that generates an HTML line for each function. This line is 8085# stored in function_info. 8086#------------------------------------------------------------------------------ 8087 my $top_of_table = $FALSE; 8088 for my $i (keys @function_info) 8089 { 8090 my $new_target_function; 8091 8092 if (defined ($function_info[$i]{"alt_name"})) 8093 { 8094 $target_function = $function_info[$i]{"alt_name"}; 8095 gp_message ("debugXL", $subr_name, "retrieved function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}"); 8096 } 8097 else 8098 { 8099 my $msg = "function_info[$i]{\"alt_name\"} is not defined"; 8100 gp_message ("assertion", $subr_name, $msg); 8101 } 8102 8103 my $function_length = $function_info[$i]{"function length"}; 8104 my $number_of_blanks = $function_view_structure{"max function length"} - $function_length; 8105 8106 my $spaces = " "; 8107 for my $i (1 .. $number_of_blanks) 8108 { 8109 $spaces .= " "; 8110 } 8111 if ($target_function eq "<Total>") 8112#------------------------------------------------------------------------------ 8113# <Total> is a pseudo function and there is no source, or disassembly for it. 8114# We could add a link to the caller-callee part, but this is currently not 8115# done. 8116#------------------------------------------------------------------------------ 8117 { 8118 $top_of_table = $TRUE; 8119 $html_line = " <b><Total></b>"; 8120 } 8121 else 8122 { 8123#------------------------------------------------------------------------------ 8124# Add the * symbol as a marker in case the same function occurs multiple times. 8125# Otherwise insert a space. 8126#------------------------------------------------------------------------------ 8127 my $base_function_name = $function_info[$i]{"routine"}; 8128 if (exists ($g_function_occurrences{$base_function_name})) 8129 { 8130 if ($g_function_occurrences{$base_function_name} > 1) 8131 { 8132 $new_target_function = "*" . $target_function; 8133 } 8134 else 8135 { 8136 $new_target_function = " " . $target_function; 8137 } 8138 } 8139 else 8140 { 8141 my $msg = "g_function_occurrences{$base_function_name} does not exist"; 8142 gp_message ("assertion", $subr_name, $msg); 8143 } 8144 8145#------------------------------------------------------------------------------ 8146# Create the block with the function name, in boldface, plus the links to the 8147# source, disassembly and caller-callee views. 8148#------------------------------------------------------------------------------ 8149 8150#------------------------------------------------------------------------------ 8151# We need to replace the "<" symbol in the code by "<". 8152#------------------------------------------------------------------------------ 8153 $new_target_function =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 8154 8155 $html_line = "<b>$new_target_function</b>" . $spaces; 8156 $html_line .= $function_info[$i]{"href_source"} . " "; 8157 $html_line .= $function_info[$i]{"href_disassembly"} . " "; 8158 $html_line .= $function_info[$i]{"href_caller_callee"}; 8159 } 8160 8161 gp_message ("debugXL", $subr_name, "target_function = $target_function html_line = $html_line"); 8162 $html_source_functions{$target_function} = $html_line; 8163 8164#------------------------------------------------------------------------------ 8165# TBD: In the future we want to re-use this block elsewhere. 8166#------------------------------------------------------------------------------ 8167 $function_info[$i]{"html function block"} = $html_line; 8168 } 8169 8170 for my $i (keys %html_source_functions) 8171 { 8172 gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}"); 8173 } 8174 for my $i (keys @function_info) 8175 { 8176 gp_message ("debugXL", $subr_name, "function_info[$i]{\"html function block\"} = " . $function_info[$i]{"html function block"}); 8177 } 8178 8179#------------------------------------------------------------------------------ 8180# Print the key data structure %function_info. This is a nested hash. 8181#------------------------------------------------------------------------------ 8182 for my $i (0 .. $#function_info) 8183 { 8184 for my $role (sort keys %{ $function_info[$i] }) 8185 { 8186 gp_message ("debug", $subr_name, "on return: function_info[$i]{$role} = $function_info[$i]{$role}"); 8187 } 8188 } 8189#------------------------------------------------------------------------------ 8190# Print the data structure %function_address_and_index. This is a nested hash. 8191#------------------------------------------------------------------------------ 8192 for my $F (keys %function_address_and_index) 8193 { 8194 for my $fields (sort keys %{ $function_address_and_index{$F} }) 8195 { 8196 gp_message ("debug", $subr_name, "on return: function_address_and_index{$F}{$fields} = $function_address_and_index{$F}{$fields}"); 8197 } 8198 } 8199#------------------------------------------------------------------------------ 8200# Print the data structure %functions_index. This is a hash with an arrray. 8201#------------------------------------------------------------------------------ 8202 for my $F (keys %functions_index) 8203 { 8204 gp_message ("debug", $subr_name, "on return: functions_index{$F} = @{ $functions_index{$F} }"); 8205# alt code for my $i (0 .. $#{ $functions_index{$F} } ) 8206# alt code { 8207# alt code gp_message ("debug", $subr_name, "on return: \$functions_index{$F} = $functions_index{$F}[$i]"); 8208# alt code } 8209 } 8210 8211#------------------------------------------------------------------------------ 8212# Print the data structure %function_view_structure. This is a hash. 8213#------------------------------------------------------------------------------ 8214 for my $F (keys %function_view_structure) 8215 { 8216 gp_message ("debug", $subr_name, "on return: function_view_structure{$F} = $function_view_structure{$F}"); 8217 } 8218 8219#------------------------------------------------------------------------------ 8220# Print the data structure %g_function_occurrences and use this structure to 8221# gather statistics about the functions. 8222# 8223# TBD: add this info to the experiment data overview. 8224#------------------------------------------------------------------------------ 8225 $number_of_unique_functions = 0; 8226 $number_of_non_unique_functions = 0; 8227 for my $F (keys %g_function_occurrences) 8228 { 8229 gp_message ("debug", $subr_name, "on return: g_function_occurrences{$F} = $g_function_occurrences{$F}"); 8230 if ($g_function_occurrences{$F} == 1) 8231 { 8232 $number_of_unique_functions++; 8233 } 8234 else 8235 { 8236 $number_of_non_unique_functions++; 8237 } 8238 } 8239 8240 for my $i (keys %g_map_function_to_index) 8241 { 8242 my $n = scalar (@{ $g_map_function_to_index{$i} }); 8243 gp_message ("debug", $subr_name, "on return: g_map_function_to_index [$n] : $i => @{ $g_map_function_to_index{$i} }"); 8244 } 8245 8246#------------------------------------------------------------------------------ 8247# TBD: Include in experiment data. Include names with multiple occurrences. 8248#------------------------------------------------------------------------------ 8249 my $msg; 8250 8251 $msg = "Number of source files : " . 8252 $num_source_files; 8253 gp_message ("debug", $subr_name, $msg); 8254 $msg = "Total number of functions: $number_of_functions"; 8255 gp_message ("debug", $subr_name, $msg); 8256 $msg = "Number of functions functions with a unique name : " . 8257 $number_of_unique_functions; 8258 gp_message ("debug", $subr_name, $msg); 8259 $msg = "Number of functions functions with more than one occurrence : " . 8260 $number_of_non_unique_functions; 8261 gp_message ("debug", $subr_name, $msg); 8262 my $multi_occurrences = $number_of_functions - $number_of_unique_functions; 8263 $msg = "Total number of multiple occurences of the same function name : " . 8264 $multi_occurrences; 8265 gp_message ("debug", $subr_name, $msg); 8266 8267 return (\@function_info, \%function_address_and_index, \%addressobjtextm, 8268 \%LINUX_vDSO, \%function_view_structure); 8269 8270} #-- End of subroutine get_function_info 8271#------------------------------------------------------------------------------ 8272# TBD 8273#------------------------------------------------------------------------------ 8274sub get_hdr_info 8275{ 8276 my $subr_name = get_my_name (); 8277 8278 my ($outputdir, $file) = @_; 8279 8280 state $first_call = $TRUE; 8281 8282 my $ASORTFILE; 8283 my @HDR; 8284 my $HDR; 8285 my $metric; 8286 my $line; 8287 my $ignore_directory; 8288 my $ignore_suffix; 8289 my $number_of_header_lines; 8290 8291#------------------------------------------------------------------------------ 8292# Add a "/" to simplify the construction of path names in the remainder. 8293#------------------------------------------------------------------------------ 8294 $outputdir = append_forward_slash ($outputdir); 8295 8296# Could get more header info from 8297# <metric>[e.bit_fcount].sort.func file - etc. 8298 8299 gp_message ("debug", $subr_name, "input file->$file<-"); 8300#----------------------------------------------- 8301 if ($file eq $outputdir."calls.sort.func") 8302 { 8303 $ASORTFILE=$outputdir."calls"; 8304 $metric = "calls" 8305 } 8306 elsif ($file eq $outputdir."calltree.sort.func") 8307 { 8308 $ASORTFILE=$outputdir."calltree"; 8309 $metric = "calltree" 8310 } 8311 elsif ($file eq $outputdir."functions.sort.func") 8312 { 8313 $ASORTFILE=$outputdir."functions.func"; 8314 $metric = "functions"; 8315 } 8316 else 8317 { 8318 $ASORTFILE = $file; 8319# $metric = basename ($file,".sort.func"); 8320 ($metric, $ignore_directory, $ignore_suffix) = fileparse ($file, ".sort.func"); 8321 gp_message ("debug", $subr_name, "ignore_directory = $ignore_directory ignore_suffix = $ignore_suffix"); 8322 } 8323 8324 gp_message ("debug", $subr_name, "file = $file metric = $metric"); 8325 8326 open (ASORTFILE,"<", $ASORTFILE) 8327 or die ("$subr_name - unable to open file $ASORTFILE for reading: '$!'"); 8328 gp_message ("debug", $subr_name, "opened file $ASORTFILE for reading"); 8329 8330 $number_of_header_lines = 0; 8331 while (<ASORTFILE>) 8332 { 8333 $line =$_; 8334 chomp ($line); 8335 8336 if ($line =~ /^Current/) 8337 { 8338 next; 8339 } 8340 if ($line =~ /^Functions/) 8341 { 8342 next; 8343 } 8344 if ($line =~ /^Callers/) 8345 { 8346 next; 8347 } 8348 if ($line =~ /^\s*$/) 8349 { 8350 next; 8351 } 8352 if (!($line =~ /^\s*\d/)) 8353 { 8354 $HDR[$number_of_header_lines] = $line; 8355 $number_of_header_lines++; 8356 next; 8357 } 8358 last; 8359 } 8360 close (ASORTFILE); 8361#------------------------------------------------------------------------------- 8362# Ruud - Fixed a bug. The output should not be appended, but overwritten. 8363# open (HI,">>$OUTPUTDIR"."hdrinfo"); 8364#------------------------------------------------------------------------------- 8365 my $outfile = $outputdir."hdrinfo"; 8366 8367 if ($first_call) 8368 { 8369 $first_call = $FALSE; 8370 open (HI ,">", $outfile) 8371 or die ("$subr_name - unable to open file $outfile for writing: '$!'"); 8372 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 8373 } 8374 else 8375 { 8376 open (HI ,">>", $outfile) 8377 or die ("$subr_name - unable to open file $outfile in append mode: '$!'"); 8378 gp_message ("debug", $subr_name, "opened file $outfile in append mode"); 8379 } 8380 8381 print HI "\#$metric hdrlines=$number_of_header_lines\n"; 8382 my $len = 0; 8383 for $HDR (@HDR) 8384 { 8385 print HI "$HDR\n"; 8386 gp_message ("debugXL", $subr_name, "HDR = $HDR\n"); 8387 } 8388 close (HI); 8389 if ($first_call) 8390 { 8391 gp_message ("debug", $subr_name, "wrote file $outfile"); 8392 } 8393 else 8394 { 8395 gp_message ("debug", $subr_name, "updated file $outfile"); 8396 } 8397#----------------------------------------------- 8398 8399} #-- End of subroutine get_hdr_info 8400 8401#------------------------------------------------------------------------------ 8402# Get the home directory and the location(s) of the configuration file on the 8403# current system. 8404#------------------------------------------------------------------------------ 8405sub get_home_dir_and_rc_path 8406{ 8407 my $subr_name = get_my_name (); 8408 8409 my ($rc_file_name) = @_; 8410 8411 my @rc_file_paths; 8412 my $target_cmd; 8413 my $home_dir; 8414 my $error_code; 8415 8416 $target_cmd = $g_mapped_cmds{"printenv"} . " HOME"; 8417 8418 ($error_code, $home_dir) = execute_system_cmd ($target_cmd); 8419 8420 if ($error_code != 0) 8421 { 8422 my $msg = "cannot find a setting for HOME - please set this"; 8423 gp_message ("assertion", $subr_name, $msg); 8424 } 8425 else 8426 8427#------------------------------------------------------------------------------ 8428# The home directory is known and we can define the locations for the 8429# configuration file. 8430#------------------------------------------------------------------------------ 8431 { 8432 @rc_file_paths = (".", "$home_dir"); 8433 } 8434 8435 gp_message ("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths"); 8436 8437 return ($home_dir, \@rc_file_paths); 8438 8439} #-- End of subroutine get_home_dir_and_rc_path 8440 8441#------------------------------------------------------------------------------ 8442# This subroutine generates a list with the hot functions. 8443#------------------------------------------------------------------------------ 8444sub get_hot_functions 8445{ 8446 my $subr_name = get_my_name (); 8447 8448 my ($exp_dir_list_ref, $summary_metrics, $input_string) = @_; 8449 8450 my @exp_dir_list = @{ $exp_dir_list_ref }; 8451 8452 my $cmd_output; 8453 my $error_code; 8454 my $expr_name; 8455 my $first_metric; 8456 my $gp_display_text_cmd; 8457 my $ignore_value; 8458 8459 my @sort_fields = (); 8460 8461 $expr_name = join (" ", @exp_dir_list); 8462 8463 gp_message ("debug", $subr_name, "expr_name = $expr_name"); 8464 8465 my $outputdir = append_forward_slash ($input_string); 8466 8467 my $script_file = $outputdir."gp-fsummary.script"; 8468 my $outfile = $outputdir."gp-fsummary.out"; 8469 my $result_file = $outputdir."gp-fsummary.stderr"; 8470 my $gp_error_file = $outputdir.$g_gp_error_logfile; 8471 8472 @sort_fields = split (":", $summary_metrics); 8473 8474#------------------------------------------------------------------------------ 8475# This is extremely unlikely to happen, but if so, it is a fatal error. 8476#------------------------------------------------------------------------------ 8477 my $number_of_elements = scalar (@sort_fields); 8478 8479 gp_message ("debug", $subr_name, "number of fields in summary_metrics = $number_of_elements"); 8480 8481 if ($number_of_elements == 0) 8482 { 8483 my $msg = "there are $number_of_elements in the metrics list"; 8484 gp_message ("assertion", $subr_name, $msg); 8485 } 8486 8487#------------------------------------------------------------------------------ 8488# Get the summary of the hot functions 8489#------------------------------------------------------------------------------ 8490 open (SCRIPT, ">", $script_file) 8491 or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); 8492 gp_message ("debug", $subr_name, "opened script file $script_file for writing"); 8493 8494#------------------------------------------------------------------------------ 8495# TBD: Check what this is about: 8496# Attributed User CPU Time=a.user : for calltree - see P37 in manual 8497#------------------------------------------------------------------------------ 8498 print SCRIPT "# limit 0\n"; 8499 print SCRIPT "limit 0\n"; 8500 print SCRIPT "# metrics $summary_metrics\n"; 8501 print SCRIPT "metrics $summary_metrics\n"; 8502 print SCRIPT "# thread_select all\n"; 8503 print SCRIPT "thread_select all\n"; 8504 8505#------------------------------------------------------------------------------ 8506# Use first out of summary metrics as first (it doesn't matter which one) 8507# $first_metric = (split /:/,$summary_metrics)[0]; 8508#------------------------------------------------------------------------------ 8509 8510 $first_metric = $sort_fields[0]; 8511 8512 print SCRIPT "# outfile $outfile\n"; 8513 print SCRIPT "outfile $outfile\n"; 8514 print SCRIPT "# sort $first_metric\n"; 8515 print SCRIPT "sort $first_metric\n"; 8516 print SCRIPT "# fsummary\n"; 8517 print SCRIPT "fsummary\n"; 8518 8519 close SCRIPT; 8520 8521 my $gp_functions_cmd = "$GP_DISPLAY_TEXT -viewmode machine -compare off -script $script_file $expr_name"; 8522 8523 gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the list of functions"); 8524 8525 $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file"; 8526 8527 ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 8528 8529 if ($error_code != 0) 8530 { 8531 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 8532 $error_code, 8533 $gp_error_file); 8534 gp_message ("abort", $subr_name, "execution terminated"); 8535 my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd"; 8536 gp_message ("abort", $subr_name, $msg); 8537 } 8538 8539 return ($outfile,\@sort_fields); 8540 8541} #-- End of subroutine get_hot_functions 8542 8543#------------------------------------------------------------------------------ 8544# For a given function name, return the index into "function_info". This 8545# index gives access to all the meta data for the input function. 8546#------------------------------------------------------------------------------ 8547sub get_index_function_info 8548{ 8549 my $subr_name = get_my_name (); 8550 8551 my ($routine_ref, $hex_address_ref, $function_info_ref) = @_; 8552 8553 my $routine = ${ $routine_ref }; 8554 my $hex_address = ${ $hex_address_ref }; 8555 my @function_info = @{ $function_info_ref }; 8556 8557#------------------------------------------------------------------------------ 8558# Check if this function has multiple occurrences. 8559#------------------------------------------------------------------------------ 8560 gp_message ("debug", $subr_name, "check for multiple occurrences"); 8561 8562 my $current_address = $hex_address; 8563 my $alt_name = $routine; 8564 8565 my $found_a_match; 8566 my $index_into_function_info; 8567 my $target_tag; 8568 8569 if (not exists ($g_multi_count_function{$routine})) 8570 { 8571#------------------------------------------------------------------------------ 8572# There is only a single occurrence and it is straightforward to get the tag. 8573#-------------------------------------------------------------------------- 8574## push (@final_function_names, $routine); 8575 if (exists ($g_map_function_to_index{$routine})) 8576 { 8577 $index_into_function_info = $g_map_function_to_index{$routine}[0]; 8578 } 8579 else 8580 { 8581 my $msg = "no entry for $routine in g_map_function_to_index"; 8582 gp_message ("assertion", $subr_name, $msg); 8583 } 8584 } 8585 else 8586 { 8587#------------------------------------------------------------------------------ 8588# The function name has more than one occurrence and we need to find the one 8589# that matches with the address. 8590#------------------------------------------------------------------------------ 8591 $found_a_match = $FALSE; 8592 gp_message ("debug", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); 8593 for my $ref (keys @{ $g_map_function_to_index{$routine} }) 8594 { 8595 my $ref_index = $g_map_function_to_index{$routine}[$ref]; 8596 my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; 8597 8598 gp_message ("debug", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); 8599 gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset"); 8600 8601#------------------------------------------------------------------------------ 8602# TBD: Do this substitution when storing "addressobjtext" in function_info. 8603#------------------------------------------------------------------------------ 8604 $addr_offset =~ s/^@\d+://; 8605 gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset"); 8606 if ($addr_offset eq $current_address) 8607 { 8608 $found_a_match = $TRUE; 8609 $index_into_function_info = $ref_index; 8610 last; 8611 } 8612 } 8613 8614#------------------------------------------------------------------------------ 8615# If there is no match, something has gone really wrong and we bail out. 8616#------------------------------------------------------------------------------ 8617 if (not $found_a_match) 8618 { 8619 my $msg = "cannot find the mapping in function_info for function $routine"; 8620 gp_message ("assertion", $subr_name, $msg); 8621 } 8622 } 8623 8624 return (\$index_into_function_info); 8625 8626} #-- End of subroutine get_index_function_info 8627 8628#------------------------------------------------------------------------------- 8629# Get the setting for LANG, or assign a default if it is not set. 8630#------------------------------------------------------------------------------- 8631sub get_LANG_setting 8632{ 8633 my $subr_name = get_my_name (); 8634 8635 my $error_code; 8636 my $lang_setting; 8637 my $target_cmd; 8638 my $command_string; 8639 my $LANG; 8640 8641 $target_cmd = $g_mapped_cmds{"printenv"}; 8642#------------------------------------------------------------------------------ 8643# Use the printenv command to get the settings for LANG. 8644#------------------------------------------------------------------------------ 8645 if ($target_cmd eq "road_to_nowhere") 8646 { 8647 $error_code = 1; 8648 } 8649 else 8650 { 8651 $command_string = $target_cmd . " LANG"; 8652 ($error_code, $lang_setting) = execute_system_cmd ($command_string); 8653 } 8654 8655 if ($error_code == 0) 8656 { 8657 chomp ($lang_setting); 8658 $LANG = $lang_setting; 8659 } 8660 else 8661 { 8662 $LANG = $g_default_setting_lang; 8663 my $msg = "cannot find a setting for LANG - use a default setting"; 8664 gp_message ("warning", $subr_name, $msg); 8665 } 8666 8667 return ($LANG); 8668 8669} #-- End of subroutine get_LANG_setting 8670 8671#------------------------------------------------------------------------------ 8672# This subroutine gathers the basic information about the metrics. 8673#------------------------------------------------------------------------------ 8674sub get_metrics_data 8675{ 8676 my $subr_name = get_my_name (); 8677 8678 my ($exp_dir_list_ref, $outputdir, $outfile1, $outfile2, $error_file) = @_; 8679 8680 my @exp_dir_list = @{ $exp_dir_list_ref }; 8681 8682 my $cmd_options; 8683 my $cmd_output; 8684 my $error_code; 8685 my $expr_name; 8686 my $metrics_cmd; 8687 my $metrics_output; 8688 my $target_cmd; 8689 8690 $expr_name = join (" ", @exp_dir_list); 8691 8692 gp_message ("debug", $subr_name, "expr_name = $expr_name"); 8693 8694#------------------------------------------------------------------------------ 8695# Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is 8696# to get all the output in files $outfile1 and $outfile2. These are then 8697# parsed. 8698#------------------------------------------------------------------------------ 8699 $cmd_options = " -viewmode machine -compare off -thread_select all"; 8700 $cmd_options .= " -outfile $outfile2"; 8701 $cmd_options .= " -fsingle '<Total>' -metric_list $expr_name"; 8702 8703 $metrics_cmd = "$GP_DISPLAY_TEXT $cmd_options 1> $outfile1 2> $error_file"; 8704 8705 gp_message ("debug", $subr_name, "command used to gather the information:"); 8706 gp_message ("debug", $subr_name, $metrics_cmd); 8707 8708 ($error_code, $metrics_output) = execute_system_cmd ($metrics_cmd); 8709 8710#------------------------------------------------------------------------------ 8711# Error handling. Any error that occurred is fatal and execution 8712# should be aborted by the caller. 8713#------------------------------------------------------------------------------ 8714 if ($error_code == 0) 8715 { 8716 gp_message ("debug", $subr_name, "metrics data in files $outfile1 and $outfile2"); 8717 } 8718 else 8719 { 8720 $target_cmd = $g_mapped_cmds{"cat"} . " $error_file"; 8721 8722 ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); 8723 8724 chomp ($cmd_output); 8725 8726 gp_message ("error", $subr_name, "contents of file $error_file:"); 8727 gp_message ("error", $subr_name, $cmd_output); 8728 } 8729 8730 return ($error_code); 8731 8732} #-- End of subroutine get_metrics_data 8733 8734#------------------------------------------------------------------------------ 8735# Wrapper that returns the last part of the subroutine name. The assumption is 8736# that the last part of the input name is of the form "aa::bb" or just "bb". 8737#------------------------------------------------------------------------------ 8738sub get_my_name 8739{ 8740 my $called_by = (caller (1))[3]; 8741 my @parts = split ("::", $called_by); 8742 return ($parts[$#parts]); 8743 8744## my ($the_full_name_ref) = @_; 8745 8746## my $the_full_name = ${ $the_full_name_ref }; 8747## my $last_part; 8748 8749#------------------------------------------------------------------------------ 8750# If the regex below fails, use the full name." 8751#------------------------------------------------------------------------------ 8752## $last_part = $the_full_name; 8753 8754#------------------------------------------------------------------------------ 8755# Capture the last part if there are multiple parts separated by "::". 8756#------------------------------------------------------------------------------ 8757## if ($the_full_name =~ /.*::(.+)$/) 8758## { 8759## if (defined ($1)) 8760## { 8761## $last_part = $1; 8762## } 8763## } 8764 8765## return (\$last_part); 8766 8767} #-- End of subroutine get_my_name 8768 8769#------------------------------------------------------------------------------- 8770# Determine the characteristics of the current system 8771#------------------------------------------------------------------------------- 8772sub get_system_config_info 8773{ 8774#------------------------------------------------------------------------------ 8775# The output from the "uname" command is used for this. Although not all of 8776# these are currently used, we store all fields in separate variables. 8777#------------------------------------------------------------------------------ 8778# 8779#------------------------------------------------------------------------------ 8780# The options supported on uname from GNU coreutils 8.22: 8781#------------------------------------------------------------------------------ 8782# -a, --all print all information, in the following order, 8783# except omit -p and -i if unknown: 8784# -s, --kernel-name print the kernel name 8785# -n, --nodename print the network node hostname 8786# -r, --kernel-release print the kernel release 8787# -v, --kernel-version print the kernel version 8788# -m, --machine print the machine hardware name 8789# -p, --processor print the processor type or "unknown" 8790# -i, --hardware-platform print the hardware platform or "unknown" 8791# -o, --operating-system print the operating system 8792#------------------------------------------------------------------------------ 8793# Sample output: 8794# 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 8795#------------------------------------------------------------------------------ 8796 my $subr_name = get_my_name (); 8797 8798 my $target_cmd; 8799 my $hostname_current; 8800 my $error_code; 8801 my $ignore_output; 8802#------------------------------------------------------------------------------ 8803# Test once if the command succeeds. This avoids we need to check every 8804# specific # command below. 8805#------------------------------------------------------------------------------ 8806 $target_cmd = $g_mapped_cmds{uname}; 8807 ($error_code, $ignore_output) = execute_system_cmd ($target_cmd); 8808 8809 if ($error_code != 0) 8810#------------------------------------------------------------------------------- 8811# This is unlikely to happen, but you never know. 8812#------------------------------------------------------------------------------- 8813 { 8814 gp_message ("abort", $subr_name, "failure to execute the uname command"); 8815 } 8816 8817 my $kernel_name = qx ($target_cmd -s); chomp ($kernel_name); 8818 my $nodename = qx ($target_cmd -n); chomp ($nodename); 8819 my $kernel_release = qx ($target_cmd -r); chomp ($kernel_release); 8820 my $kernel_version = qx ($target_cmd -v); chomp ($kernel_version); 8821 my $machine = qx ($target_cmd -m); chomp ($machine); 8822 my $processor = qx ($target_cmd -p); chomp ($processor); 8823 my $hardware_platform = qx ($target_cmd -i); chomp ($hardware_platform); 8824 my $operating_system = qx ($target_cmd -o); chomp ($operating_system); 8825 8826 $local_system_config{"kernel_name"} = $kernel_name; 8827 $local_system_config{"nodename"} = $nodename; 8828 $local_system_config{"kernel_release"} = $kernel_release; 8829 $local_system_config{"kernel_version"} = $kernel_version; 8830 $local_system_config{"machine"} = $machine; 8831 $local_system_config{"processor"} = $processor; 8832 $local_system_config{"hardware_platform"} = $hardware_platform; 8833 $local_system_config{"operating_system"} = $operating_system; 8834 8835 gp_message ("debug", $subr_name, "the output from the $target_cmd command is split into the following variables:"); 8836 gp_message ("debug", $subr_name, "kernel_name = $kernel_name"); 8837 gp_message ("debug", $subr_name, "nodename = $nodename"); 8838 gp_message ("debug", $subr_name, "kernel_release = $kernel_release"); 8839 gp_message ("debug", $subr_name, "kernel_version = $kernel_version"); 8840 gp_message ("debug", $subr_name, "machine = $machine"); 8841 gp_message ("debug", $subr_name, "processor = $processor"); 8842 gp_message ("debug", $subr_name, "hardware_platform = $hardware_platform"); 8843 gp_message ("debug", $subr_name, "operating_system = $operating_system"); 8844 8845#------------------------------------------------------------------------------ 8846# Check if the system we are running on is supported. 8847#------------------------------------------------------------------------------ 8848 my $is_supported = ${ check_support_for_processor (\$machine) }; 8849 8850 if (not $is_supported) 8851 { 8852 gp_message ("error", $subr_name, "$machine is not supported"); 8853 exit (0); 8854 } 8855#------------------------------------------------------------------------------ 8856# The current hostname is used to compare against the hostname(s) found in the 8857# experiment directories. 8858#------------------------------------------------------------------------------ 8859 $target_cmd = $g_mapped_cmds{hostname}; 8860 $hostname_current = qx ($target_cmd); chomp ($hostname_current); 8861 $error_code = ${^CHILD_ERROR_NATIVE}; 8862 8863 if ($error_code == 0) 8864 { 8865 $local_system_config{"hostname_current"} = $hostname_current; 8866 } 8867 else 8868#------------------------------------------------------------------------------- 8869# This is unlikely to happen, but you never know. 8870#------------------------------------------------------------------------------- 8871 { 8872 gp_message ("abort", $subr_name, "failure to execute the hostname command"); 8873 } 8874 for my $key (sort keys %local_system_config) 8875 { 8876 gp_message ("debug", $subr_name, "local_system_config{$key} = $local_system_config{$key}"); 8877 } 8878 8879 return (0); 8880 8881} #-- End of subroutine get_system_config_info 8882 8883#------------------------------------------------------------------------------- 8884# This subroutine prints a message. Several types of messages are supported. 8885# In case the type is "abort", or "error", execution is terminated. 8886# 8887# Note that "debug", "warning", and "error" mode, the name of the calling 8888# subroutine is truncated to 30 characters. In case the name is longer, 8889# a warning message # is issued so you know this has happened. 8890# 8891# Note that we use lcfirst () and ucfirst () to enforce whether the first 8892# character is printed in lower or uppercase. It is nothing else than a 8893# convenience, but creates more consistency across messages. 8894#------------------------------------------------------------------------------- 8895sub gp_message 8896{ 8897 my $subr_name = get_my_name (); 8898 8899 my ($action, $caller_name, $comment_line) = @_; 8900 8901#------------------------------------------------------------------------------- 8902# The debugXL identifier is special. It is accepted, but otherwise ignored. 8903# This allows to (temporarily) disable debug print statements, but keep them 8904# around. 8905#------------------------------------------------------------------------------- 8906 my %supported_identifiers = ( 8907 "verbose" => "[Verbose]", 8908 "debug" => "[Debug]", 8909 "error" => "[Error]", 8910 "warning" => "[Warning]", 8911 "abort" => "[Abort]", 8912 "assertion" => "[Assertion error]", 8913 "diag" => "", 8914 ); 8915 8916 my $debug_size; 8917 my $identifier; 8918 my $fixed_size_name; 8919 my $string_limit = 30; 8920 my $strlen = length ($caller_name); 8921 my $trigger_debug = $FALSE; 8922 my $truncated_name; 8923 my $msg; 8924 8925 if ($action =~ /debug\s*(.+)/) 8926 { 8927 if (defined ($1)) 8928 { 8929 my $orig_value = $1; 8930 $debug_size = lc ($1); 8931 8932 if ($debug_size =~ /^s$|^m$|^l$|^xl$/) 8933 { 8934 if ($g_debug_size{$debug_size}) 8935 { 8936#------------------------------------------------------------------------------- 8937# All we need to know is whether a debug action is requested and whether the 8938# size has been enabled. By setting $action to "debug", the code below is 8939# simplified. Note that only using $trigger_debug below is actually sufficient. 8940#------------------------------------------------------------------------------- 8941 $trigger_debug = $TRUE; 8942 } 8943 } 8944 else 8945 { 8946 die "$subr_name: debug size $orig_value is not supported"; 8947 } 8948 $action = "debug"; 8949 } 8950 } 8951 elsif ($action eq "debug") 8952 { 8953 $trigger_debug = $TRUE; 8954 } 8955 8956#------------------------------------------------------------------------------- 8957# Catch any non-supported identifier. 8958#------------------------------------------------------------------------------- 8959 if (defined ($supported_identifiers{$action})) 8960 { 8961 $identifier = $supported_identifiers{$action}; 8962 } 8963 else 8964 { 8965 die ("$subr_name - input error: $action is not supported"); 8966 } 8967 if (($action eq "debug") and ($g_user_settings{"debug"}{"current_value"} eq "off")) 8968 { 8969 $trigger_debug = $FALSE; 8970 } 8971 8972#------------------------------------------------------------------------------- 8973# Unconditionally buffer all warning messages. These are meant to be displayed 8974# separately. 8975#------------------------------------------------------------------------------- 8976 if ($action eq "warning") 8977 { 8978 push (@g_warning_messages, ucfirst ($comment_line)); 8979 } 8980 8981#------------------------------------------------------------------------------- 8982# Quick return in several cases. Note that "debug", "verbose", "warning", and 8983# "diag" messages are suppressed in quiet mode, but "error", "abort" and 8984# "assertion" always pass. 8985#------------------------------------------------------------------------------- 8986 if (( 8987 ($action eq "verbose") and (not $g_verbose)) 8988 or (($action eq "debug") and (not $trigger_debug)) 8989 or (($action eq "verbose") and ($g_quiet)) 8990 or (($action eq "debug") and ($g_quiet)) 8991 or (($action eq "warning") and (not $g_warnings)) 8992 or (($action eq "diag") and ($g_quiet))) 8993 { 8994 return (0); 8995 } 8996 8997#------------------------------------------------------------------------------- 8998# In diag mode, just print the input line and nothing else. 8999#------------------------------------------------------------------------------- 9000 if (( 9001 $action eq "debug") 9002 or ($action eq "abort") 9003 or ($action eq "warning") 9004 or ($action eq "assertion") 9005 or ($action eq "error")) 9006 { 9007#------------------------------------------------------------------------------- 9008# Construct the string to be printed. Include an identifier and the name of 9009# the function. 9010#------------------------------------------------------------------------------- 9011 if ($strlen > $string_limit) 9012 { 9013 $truncated_name = substr ($caller_name, 0, $string_limit); 9014 $fixed_size_name = sprintf ("%-"."$string_limit"."s", $truncated_name); 9015 print "Warning in $subr_name - the name of the caller is: $caller_name\n"; 9016 print "Warning in $subr_name - the string length is $strlen and exceeds $string_limit\n"; 9017 } 9018 else 9019 { 9020 $fixed_size_name = sprintf ("%-"."$string_limit"."s", $caller_name); 9021 } 9022 9023 if (($action eq "error") or ($action eq "abort")) 9024#------------------------------------------------------------------------------- 9025# Enforce that the message starts with a lowercase symbol. Since these are 9026# user errors, the name of the routine is not shown. The same for "abort". 9027# If you want to display the routine name too, use an assertion. 9028#------------------------------------------------------------------------------- 9029 { 9030 printf ("%-9s %s\n", $identifier, lcfirst ($comment_line)); 9031 } 9032 elsif ($action eq "assertion") 9033#------------------------------------------------------------------------------- 9034# Enforce that the message starts with a lowercase symbol. 9035#------------------------------------------------------------------------------- 9036 { 9037 printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line); 9038 } 9039 elsif (($action eq "debug") and ($trigger_debug)) 9040#------------------------------------------------------------------------------- 9041# Debug messages are printed "as is". Avoids issues when searching for them ;-) 9042#------------------------------------------------------------------------------- 9043 { 9044 printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, $comment_line); 9045 } 9046 else 9047#------------------------------------------------------------------------------- 9048# Enforce that the message starts with a lowercase symbol. 9049#------------------------------------------------------------------------------- 9050 { 9051 printf ("%-9s %-30s - %s\n", $identifier, $fixed_size_name, lcfirst ($comment_line)); 9052 } 9053 } 9054 elsif ($action eq "verbose") 9055#------------------------------------------------------------------------------- 9056# The first character in the verbose message is capatilized. 9057#------------------------------------------------------------------------------- 9058 { 9059 printf ("%s\n", ucfirst ($comment_line)); 9060 } 9061 elsif ($action eq "diag") 9062#------------------------------------------------------------------------------- 9063# The diag messages are meant to be diagnostics. Only the comment line is 9064# printed. 9065#------------------------------------------------------------------------------- 9066 { 9067 printf ("%s\n", $comment_line); 9068 return (0); 9069 } 9070 9071#------------------------------------------------------------------------------- 9072# Terminate execution in case the identifier is "abort". 9073#------------------------------------------------------------------------------- 9074 if (($action eq "abort") or ($action eq "assertion")) 9075 { 9076## print "ABORT temporarily disabled for testing purposes\n"; 9077 exit (-1); 9078 } 9079 else 9080 { 9081 return (0); 9082 } 9083 9084} #-- End of subroutine gp_message 9085 9086#------------------------------------------------------------------------------ 9087# Dynamically load the modules needed. Returns a list with the modules that 9088# could not be loaded. 9089#------------------------------------------------------------------------------ 9090sub handle_module_availability 9091{ 9092 my $subr_name = get_my_name (); 9093 9094 gp_message ("verbose", $subr_name, "Handling module requirements"); 9095 9096#------------------------------------------------------------------------------ 9097# This is clunky at best, but there is a chicken egg problem here. For the 9098# man page to be generated, the --help and --version options need to work, 9099# but this part of the code only works if the "stat" function is available. 9100# The "feature qw (state)" is required for the code to compile. 9101# 9102# TBD: Consider using global variables and to decouple parts of the option 9103# handling. 9104#; 9105## my @modules_used = ("feature", 9106## "File::stat", 9107#------------------------------------------------------------------------------ 9108 my @modules_used = ( 9109 "List::Util", 9110 "Cwd", 9111 "File::Basename", 9112 "File::stat", 9113 "POSIX", 9114 "bigint", 9115 "bignum"); 9116 9117 my @missing_modules = (); 9118 my $cmd; 9119 my $result; 9120 9121#------------------------------------------------------------------------------ 9122# This loop checks for the availability of the modules and if so, imports 9123# the module. 9124# 9125# The names of missing modules, if any, are stored and printed in the error 9126# handling section below. 9127#------------------------------------------------------------------------------ 9128 for my $i (0 .. $#modules_used) 9129 { 9130 my $m = $modules_used[$i]; 9131 if (eval "require $m;") 9132 { 9133 if ($m eq "feature") 9134 { 9135 $cmd = $m . "->import ( qw (state))"; 9136 } 9137 elsif ($m eq "List::Util") 9138 { 9139 $cmd = $m . "->import ( qw (min max))"; 9140 } 9141 elsif ($m eq "bigint") 9142 { 9143 $cmd = $m . "->import ( qw (hex))"; 9144 } 9145 else 9146 { 9147 $cmd = $m . "->import"; 9148 } 9149 $cmd .= ";"; 9150 $result = eval ("$cmd"); 9151 gp_message ("debugM", $subr_name, "cmd = $cmd"); 9152 } 9153 else 9154 { 9155 push (@missing_modules, $m); 9156 } 9157 } 9158 9159#------------------------------------------------------------------------------ 9160# Count the number of missing modules. It is upon the caller to decide what 9161# to do in case of errors. Currently, execution is aborted. 9162#------------------------------------------------------------------------------ 9163 my $errors = scalar (@missing_modules); 9164 9165 return (\$errors, \@missing_modules); 9166 9167} #-- End of subroutine handle_module_availability 9168 9169#------------------------------------------------------------------------------ 9170# Generate the HTML with the experiment summary. 9171#------------------------------------------------------------------------------ 9172sub html_generate_exp_summary 9173{ 9174 my $subr_name = get_my_name (); 9175 9176 my ($outputdir_ref, $experiment_data_ref) = @_; 9177 9178 my $outputdir = ${ $outputdir_ref }; 9179 my @experiment_data = @{ $experiment_data_ref }; 9180 my $file_title; 9181 my $outfile; 9182 my $page_title; 9183 my $size_text; 9184 my $position_text; 9185 my $html_header; 9186 my $html_home; 9187 my $html_title_header; 9188 my $html_acknowledgement; 9189 my $html_end; 9190 my @html_exp_table_data = (); 9191 my $html_exp_table_data_ref; 9192 my @table_execution_stats = (); 9193 my $table_execution_stats_ref; 9194 9195 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 9196 $outputdir = append_forward_slash ($outputdir); 9197 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 9198 9199 $file_title = "Experiment information"; 9200 $page_title = "Experiment Information"; 9201 $size_text = "h2"; 9202 $position_text = "center"; 9203 $html_header = ${ create_html_header (\$file_title) }; 9204 $html_home = ${ generate_home_link ("right") }; 9205 9206 $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 9207 9208 $outfile = $outputdir . $g_html_base_file_name{"experiment_info"} . ".html"; 9209 open (EXP_INFO, ">", $outfile) 9210 or die ("unable to open $outfile for writing - '$!'"); 9211 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 9212 9213 print EXP_INFO $html_header; 9214 print EXP_INFO $html_home; 9215 print EXP_INFO $html_title_header; 9216 9217 ($html_exp_table_data_ref, $table_execution_stats_ref) = html_generate_table_data ($experiment_data_ref); 9218 9219 @html_exp_table_data = @{ $html_exp_table_data_ref }; 9220 @table_execution_stats = @{ $table_execution_stats_ref }; 9221 9222 print EXP_INFO "$_" for @html_exp_table_data; 9223; 9224## print EXP_INFO "<pre>\n"; 9225## print EXP_INFO "$_\n" for @html_caller_callee; 9226## print EXP_INFO "</pre>\n"; 9227 9228#------------------------------------------------------------------------------- 9229# Get the acknowledgement, return to main link, and final html statements. 9230#------------------------------------------------------------------------------- 9231 $html_home = ${ generate_home_link ("left") }; 9232 $html_acknowledgement = ${ create_html_credits () }; 9233 $html_end = ${ terminate_html_document () }; 9234 9235 print EXP_INFO $html_home; 9236 print EXP_INFO "<br>\n"; 9237 print EXP_INFO $html_acknowledgement; 9238 print EXP_INFO $html_end; 9239 9240 close (EXP_INFO); 9241 9242 return (\@table_execution_stats); 9243 9244} #-- End of subroutine html_generate_exp_summary 9245 9246#------------------------------------------------------------------------------- 9247# Generate the entries for the tables with the experiment info. 9248#------------------------------------------------------------------------------- 9249sub html_generate_table_data 9250{ 9251 my $subr_name = get_my_name (); 9252 9253 my ($experiment_data_ref) = @_; 9254 9255 my @experiment_data = (); 9256 my @html_exp_table_data = (); 9257 my $html_line; 9258## my $html_header_line; 9259 my $entry_name; 9260 my $key; 9261 my $size_text; 9262 my $position_text; 9263 my $title_table_1; 9264 my $title_table_2; 9265 my $title_table_3; 9266 my $title_table_summary; 9267 my $html_table_title; 9268 9269 my @experiment_table_1_def = (); 9270 my @experiment_table_2_def = (); 9271 my @experiment_table_3_def = (); 9272 my @exp_table_summary_def = (); 9273 my @experiment_table_1 = (); 9274 my @experiment_table_2 = (); 9275 my @experiment_table_3 = (); 9276 my @exp_table_summary = (); 9277 my @exp_table_selection = (); 9278 9279 @experiment_data = @{ $experiment_data_ref }; 9280 9281 for my $i (sort keys @experiment_data) 9282 { 9283 for my $fields (sort keys %{ $experiment_data[$i] }) 9284 { 9285 gp_message ("debugXL", $subr_name, "$i => experiment_data[$i]{$fields} = $experiment_data[$i]{$fields}"); 9286 } 9287 } 9288 9289 $title_table_1 = "Target System Configuration"; 9290 $title_table_2 = "Experiment Statistics"; 9291 $title_table_3 = "Run Time Statistics"; 9292 $title_table_summary = "Main Statistics"; 9293 9294 $size_text = "h3"; 9295 $position_text = "left"; 9296 9297 push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"}; 9298 push @experiment_table_1_def, { name => "Hostname" , key => "hostname"}; 9299 push @experiment_table_1_def, { name => "Operating system", key => "OS"}; 9300 push @experiment_table_1_def, { name => "Architecture", key => "architecture"}; 9301 push @experiment_table_1_def, { name => "Page size", key => "page_size"}; 9302 9303 push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"}; 9304 push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"}; 9305 push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"}; 9306 push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"}; 9307 9308 push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; 9309## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"}; 9310 push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; 9311## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"}; 9312 push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"}; 9313## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"}; 9314 9315 push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"}; 9316 push @exp_table_summary_def, { name => "Hostname" , key => "hostname"}; 9317 push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; 9318 push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; 9319 push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"}; 9320 9321 $html_table_title = ${ generate_a_header (\$title_table_1, \$size_text, \$position_text) }; 9322 9323 push (@html_exp_table_data, $html_table_title); 9324 9325 @experiment_table_1 = @{ create_table (\@experiment_data, \@experiment_table_1_def) }; 9326 9327 push (@html_exp_table_data, @experiment_table_1); 9328 9329 $html_table_title = ${ generate_a_header (\$title_table_2, \$size_text, \$position_text) }; 9330 9331 push (@html_exp_table_data, $html_table_title); 9332 9333 @experiment_table_2 = @{ create_table (\@experiment_data, \@experiment_table_2_def) }; 9334 9335 push (@html_exp_table_data, @experiment_table_2); 9336 9337 $html_table_title = ${ generate_a_header (\$title_table_3, \$size_text, \$position_text) }; 9338 9339 push (@html_exp_table_data, $html_table_title); 9340 9341 @experiment_table_3 = @{ create_table (\@experiment_data, \@experiment_table_3_def) }; 9342 9343 push (@html_exp_table_data, @experiment_table_3); 9344 9345 $html_table_title = ${ generate_a_header (\$title_table_summary, \$size_text, \$position_text) }; 9346 9347 push (@exp_table_summary, $html_table_title); 9348 9349 @exp_table_selection = @{ create_table (\@experiment_data, \@exp_table_summary_def) }; 9350 9351 push (@exp_table_summary, @exp_table_selection); 9352 9353 return (\@html_exp_table_data, \@exp_table_summary); 9354 9355} #-- End of subroutine html_generate_table_data 9356 9357#------------------------------------------------------------------------------ 9358# Generate the HTML text to print in case a file is empty. 9359#------------------------------------------------------------------------------ 9360sub html_text_empty_file 9361{ 9362 my $subr_name = get_my_name (); 9363 9364 my ($comment_ref, $error_file_ref) = @_; 9365 9366 my $comment; 9367 my $error_file; 9368 my $error_message; 9369 my $file_title; 9370 my $html_end; 9371 my $html_header; 9372 my $html_home; 9373 9374 my @html_empty_file = (); 9375 9376 $comment = ${ $comment_ref }; 9377 $error_file = ${ $error_file_ref }; 9378 9379 $file_title = "File is empty"; 9380 $html_header = ${ create_html_header (\$file_title) }; 9381 $html_end = ${ terminate_html_document () }; 9382 $html_home = ${ generate_home_link ("left") }; 9383 9384 push (@html_empty_file, $html_header); 9385 9386 $error_message = "<b>" . $comment . "</b>"; 9387 $error_message = set_background_color_string ($error_message, $g_html_color_scheme{"error_message"}); 9388 push (@html_empty_file, $error_message); 9389 9390 if (not is_file_empty ($error_file)) 9391 { 9392 $error_message = "<p><em>Check file $error_file for more information</em></p>"; 9393 } 9394 push (@html_empty_file, $error_message); 9395 push (@html_empty_file, $html_home); 9396 push (@html_empty_file, "<br>"); 9397 push (@html_empty_file, $g_html_credits_line); 9398 push (@html_empty_file, $html_end); 9399 9400 return (\@html_empty_file); 9401 9402} #-- End of subroutine html_text_empty_file 9403 9404#------------------------------------------------------------------------------ 9405# This subroutine checks if a file is empty and returns $TRUE or $FALSE. 9406#------------------------------------------------------------------------------ 9407sub is_file_empty 9408{ 9409 my $subr_name = get_my_name (); 9410 9411 my ($filename) = @_; 9412 9413 my $size; 9414 my $file_stat; 9415 my $is_empty; 9416 9417 chomp ($filename); 9418 9419 if (not -e $filename) 9420 { 9421#------------------------------------------------------------------------------ 9422# The return value is used in the caller. This is why we return the empty 9423# string in case the file does not exist. 9424#------------------------------------------------------------------------------ 9425 gp_message ("debug", $subr_name, "filename = $filename not found"); 9426 $is_empty = $TRUE; 9427 } 9428 else 9429 { 9430 $file_stat = stat ($filename); 9431 $size = $file_stat->size; 9432 $is_empty = ($size == 0) ? $TRUE : $FALSE; 9433 } 9434 9435 gp_message ("debug", $subr_name, "filename = $filename size = $size is_empty = $is_empty"); 9436 9437 return ($is_empty); 9438 9439} #-- End of subroutine is_file_empty 9440 9441#------------------------------------------------------------------------------ 9442# Check if a file is executable and return $TRUE or $FALSE. 9443#------------------------------------------------------------------------------ 9444sub is_file_executable 9445{ 9446 my $subr_name = get_my_name (); 9447 9448 my ($filename) = @_; 9449 9450 my $file_permissions; 9451 my $index_offset; 9452 my $is_executable; 9453 my $mode; 9454 my $number_of_bytes; 9455 my @permission_settings = (); 9456 my %permission_values = (); 9457 9458 chomp ($filename); 9459 9460 gp_message ("debug", $subr_name, "check if filename = $filename is executable"); 9461 9462 if (not -e $filename) 9463 { 9464#------------------------------------------------------------------------------ 9465# The return value is used in the caller. This is why we return the empty 9466# string in case the file does not exist. 9467#------------------------------------------------------------------------------ 9468 gp_message ("debug", $subr_name, "filename = $filename not found"); 9469 $is_executable = $FALSE; 9470 } 9471 else 9472 { 9473 $mode = stat ($filename)->mode; 9474 9475 gp_message ("debugXL", $subr_name, "mode = $mode"); 9476#------------------------------------------------------------------------------ 9477# Get username. We currently do not do anything with this though and the 9478# code is commented out. 9479# 9480# my $my_name = getlogin () || getpwuid($<) || "Kilroy";; 9481# gp_message ("debug", $subr_name, "my_name = $my_name"); 9482#------------------------------------------------------------------------------ 9483 9484#------------------------------------------------------------------------------ 9485# Convert file permissions to octal, split the individual numbers and store 9486# the values for the respective users. 9487#------------------------------------------------------------------------------ 9488 $file_permissions = sprintf("%o", $mode & 07777); 9489 9490 @permission_settings = split (//, $file_permissions); 9491 9492 $number_of_bytes = scalar (@permission_settings); 9493 9494 gp_message ("debugXL", $subr_name, "file_permissions = $file_permissions"); 9495 gp_message ("debugXL", $subr_name, "permission_settings = @permission_settings"); 9496 gp_message ("debugXL", $subr_name, "number_of_settings = $number_of_bytes"); 9497 9498 if ($number_of_bytes == 4) 9499 { 9500 $index_offset = 1; 9501 } 9502 elsif ($number_of_bytes == 3) 9503 { 9504 $index_offset = 0; 9505 } 9506 else 9507 { 9508 my $msg = "unexpected number of $number_of_bytes bytes " . 9509 "in permission settings: @permission_settings"; 9510 gp_message ("assertion", $subr_name, $msg); 9511 } 9512 9513 $permission_values{user} = $permission_settings[$index_offset++]; 9514 $permission_values{group} = $permission_settings[$index_offset++]; 9515 $permission_values{other} = $permission_settings[$index_offset]; 9516 9517#------------------------------------------------------------------------------ 9518# The executable bit should be set for user, group and other. If this fails 9519# we mark the file as not executable. Note that this is gprofng specific. 9520#------------------------------------------------------------------------------ 9521 $is_executable = $TRUE; 9522 for my $k (keys %permission_values) 9523 { 9524 my $msg = "permission_values{" . $k . "} = " . 9525 $permission_values{$k}; 9526 gp_message ("debugXL", $subr_name, $msg); 9527 9528 if ($permission_values{$k} % 2 == 0) 9529 { 9530 $is_executable = $FALSE; 9531 last; 9532 } 9533 } 9534 } 9535 9536 gp_message ("debug", $subr_name, "is_executable = $is_executable"); 9537 9538 return ($is_executable); 9539 9540} #-- End of subroutine is_file_executable 9541 9542#------------------------------------------------------------------------------- 9543# TBD. 9544#------------------------------------------------------------------------------- 9545sub name_regex 9546{ 9547 my $subr_name = get_my_name (); 9548 9549 my ($metric_description_ref, $metrics, $field, $file) = @_; 9550 9551 my %metric_description = %{ $metric_description_ref }; 9552 9553 my @splitted_metrics; 9554 my $splitted_metrics; 9555 my $m; 9556 my $mf; 9557 my $nf; 9558 my $re; 9559 my $Xre; 9560 my $noPCfile; 9561 my @reported_metrics; 9562 my $reported_metrics; 9563 my $hdr_regex; 9564 my $hdr_href_regex; 9565 my $hdr_src_regex; 9566 my $new_metrics; 9567 my $pre; 9568 my $post; 9569 my $rat; 9570 my @moo = (); 9571 9572 my $gp_metrics_file; 9573 my $gp_metrics_dir; 9574 my $suffix_not_used; 9575 9576 my $is_calls = $FALSE; 9577 my $is_calltree = $FALSE; 9578 9579 gp_message ("debugXL", $subr_name,"1:metrics->$metrics<- field->$field<- file->$file<-"); 9580 9581#------------------------------------------------------------------------------- 9582# According to https://perldoc.perl.org/File::Basename, both dirname and 9583# basename are not reliable and fileparse () is recommended instead. 9584# 9585# Note that $gp_metrics_dir has a trailing "/". 9586#------------------------------------------------------------------------------- 9587 ($gp_metrics_file, $gp_metrics_dir, $suffix_not_used) = fileparse ($file, ".sort.func-PC"); 9588 9589 gp_message ("debugXL", $subr_name, "gp_metrics_dir = $gp_metrics_dir gp_metrics_file = $gp_metrics_file"); 9590 gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used"); 9591 9592 if ($gp_metrics_file eq "calls") 9593 { 9594 $is_calls = $TRUE; 9595 } 9596 if ($gp_metrics_file eq "calltree") 9597 { 9598 $is_calltree = $TRUE; 9599 } 9600 9601 $gp_metrics_file = "gp-metrics-" . $gp_metrics_file . "-PC"; 9602 $gp_metrics_file = $gp_metrics_dir . $gp_metrics_file; 9603 9604 gp_message ("debugXL", $subr_name, "gp_metrics_file is $gp_metrics_file"); 9605 9606 open (GP_METRICS, "<", $gp_metrics_file) 9607 or die ("$subr_name - unable to open gp_metrics file $gp_metrics_file for reading - '$!'"); 9608 gp_message ("debug", $subr_name, "opened file $gp_metrics_file for reading"); 9609 9610 $new_metrics = $metrics; 9611 9612 while (<GP_METRICS>) 9613 { 9614 $rat = $_; 9615 chomp ($rat); 9616 gp_message ("debugXL", $subr_name, "rat = $rat - new_metrics = $new_metrics"); 9617#------------------------------------------------------------------------------- 9618# Capture the string after "Current metrics:" and if it ends with ":name", 9619# remove it. 9620#------------------------------------------------------------------------------- 9621 if ($rat =~ /^\s*Current metrics:\s*(.*)$/) 9622 { 9623 $new_metrics = $1; 9624 if ($new_metrics =~ /^(.*):name$/) 9625 { 9626 $new_metrics = $1; 9627 } 9628 last; 9629 } 9630 } 9631 close (GP_METRICS); 9632 9633 if ($is_calls or $is_calltree) 9634 { 9635#------------------------------------------------------------------------------- 9636# Remove any inclusive metrics from the list. 9637#------------------------------------------------------------------------------- 9638 while ($new_metrics =~ /(.*)(i\.[^:]+)(.*)$/) 9639 { 9640 $pre = $1; 9641 $post = $3; 9642 gp_message ("debugXL", $subr_name, "1b: new_metrics = $new_metrics pre = $pre post = $post"); 9643 if (substr ($post,0,1) eq ":") 9644 { 9645 $post = substr ($post,1); 9646 } 9647 $new_metrics = $pre.$post; 9648 } 9649 } 9650 9651 $metrics = $new_metrics; 9652 9653 gp_message ("debugXL", $subr_name, "2:metrics->$metrics<- field->$field<- file->$file<-"); 9654 9655#------------------------------------------------------------------------------- 9656# Find the line starting with "address:" and strip this part away. 9657#------------------------------------------------------------------------------- 9658 if ($metrics =~ /^address:(.*)/) 9659 { 9660 $reported_metrics = $1; 9661#------------------------------------------------------------------------------- 9662# Focus on the filename ending with "-PC". When found, strip this part away. 9663#------------------------------------------------------------------------------- 9664 if ($file =~ /^(.*)-PC$/) 9665 { 9666 $noPCfile = $1; 9667 if ($noPCfile =~ /^(.*)functions.sort.func$/) 9668 { 9669 $noPCfile = $1."functions.func"; 9670 } 9671 push (@moo, "$reported_metrics\n"); 9672 } 9673 } 9674 9675#------------------------------------------------------------------------------- 9676# Split the list into an array with the individual metrics. 9677# 9678# TBD: This should be done only once! 9679#------------------------------------------------------------------------------- 9680 @reported_metrics = split (":", $reported_metrics); 9681 for my $i (@reported_metrics) 9682 { 9683 gp_message ("debugXL", $subr_name, "reported_metrics = $i"); 9684 } 9685 9686 $hdr_regex = "^\\s*"; 9687 $hdr_href_regex = "^\\s*"; 9688 $hdr_src_regex = "^(\\s+|<i>\\s+)"; 9689 9690 for my $m (@reported_metrics) 9691 { 9692 9693 my $description = ${ retrieve_metric_description (\$m, \%metric_description) }; 9694 gp_message ("debugXL", $subr_name, "m = $m description = $description"); 9695 if (substr ($m,0,1) eq "e") 9696 { 9697 push (@moo,"$m:$description\n"); 9698 $hdr_regex .= "(Excl\\.\.*)"; 9699 $hdr_href_regex .= "(<a.*>)(Excl\\.)(<\/a>)([^<]+)"; 9700 $hdr_src_regex .= "(Excl\\.\.*)"; 9701 next; 9702 } 9703 if (substr ($m,0,1) eq "i") 9704 { 9705 push (@moo,"$m:$description\n"); 9706 $hdr_regex .= "(Incl\\.\.*)"; 9707 $hdr_href_regex .= "(<a.*>)(Incl\\.)(<\/a>)([^<]+)"; 9708 $hdr_src_regex .= "(Incl\\.\.*)"; 9709 next; 9710 } 9711 if (substr ($m,0,1) eq "a") 9712 { 9713 my $a; 9714 my $am; 9715 $a = $m; 9716 $a =~ s/^a/e/; 9717 $am = ${ retrieve_metric_description (\$a, \%metric_description) }; 9718 $am =~ s/Exclusive/Attributed/; 9719 push (@moo,"$m:$am\n"); 9720 $hdr_regex .= "(Attr\\.\.*)"; 9721 $hdr_href_regex .= "(<a.*>)(Attr\\.)(<\/a>)([^<]+)"; 9722 $hdr_src_regex .= "(Attr\\.\.*)";next; 9723 } 9724 } 9725 9726 $hdr_regex .= "(Name\.*)"; 9727 $hdr_href_regex .= "(Name\.*)"; 9728 9729 @splitted_metrics = split (":","$metrics"); 9730 $nf = scalar (@splitted_metrics); 9731 gp_message ("debug", $subr_name,"number of fields in $metrics -> $nf"); 9732 9733 open (ZMETRICS, ">", "$noPCfile.metrics") 9734 or die ("Not able to open file $noPCfile.metrics for writing - '$!'"); 9735 gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.metrics for writing"); 9736 9737 print ZMETRICS @moo; 9738 close (ZMETRICS); 9739 9740 gp_message ("debug", $subr_name, "wrote file $noPCfile.metrics"); 9741 9742 open (XREGEXP, ">", "$noPCfile.c.regex") 9743 or die ("Not able to open file $noPCfile.c.regex for writing - '$!'"); 9744 gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.c.regex for writing"); 9745 9746 print XREGEXP "\# Number of metric fields\n"; 9747 print XREGEXP "$nf\n"; 9748 print XREGEXP "\# Header regex\n"; 9749 print XREGEXP "$hdr_regex\n"; 9750 print XREGEXP "\# href Header regex\n"; 9751 print XREGEXP "$hdr_href_regex\n"; 9752 print XREGEXP "\# src Header regex\n"; 9753 print XREGEXP "$hdr_src_regex\n"; 9754 9755 $mf = 1; 9756#--------------------------------------------------------------------------- 9757# Find the index of "field" in the metric list, plus one. 9758#--------------------------------------------------------------------------- 9759 if ( ($field eq "functions") or ($field eq "calls") or ($field eq "calltree")) 9760 { 9761 $mf = $nf + 1; 9762 } 9763 else 9764 { 9765 for my $candidate_metric (@splitted_metrics) 9766 { 9767 gp_message ("debugXL", $subr_name, "field = $field candidate_metric = $candidate_metric and mf = $mf"); 9768 if ($candidate_metric eq $field) 9769 { 9770 last; 9771 } 9772 $mf++; 9773 } 9774 } 9775 gp_message ("debugXL", $subr_name, "Final value mf = $mf"); 9776 9777 if ($mf == 1) 9778 { 9779 $re = "^\\s*(\\S+)"; # metric value 9780 } 9781 else 9782 { 9783 $re = "^\\s*\\S+"; 9784 } 9785 $Xre = "^\\s*(\\S+)"; 9786 9787 $m = 2; 9788 while (--$nf) 9789 { 9790 if ($nf) 9791 { 9792 if ($m == $mf) 9793 { 9794 $re .= "\\s+(\\S+)"; # metric value 9795 } 9796 else 9797 { 9798 $re .= "\\s+\\S+"; 9799 } 9800 if ($nf != 1) 9801 { 9802 $Xre .= "\\s+(\\S+)"; 9803 } 9804 $m++; 9805 } 9806 } 9807 9808 if ($field eq "calltree") 9809 { 9810 $re .= "\\s+.*\\+-(.*)"; # name 9811 $Xre .= "\\s+.*\\+-(.*)\$"; # name (Right?) 9812 } 9813 else 9814 { 9815 $re .= "\\s+(.*)"; # name 9816 $Xre .= "\\s+(.*)\$"; # name 9817 } 9818 9819 print XREGEXP "\# Metrics and Name regex\n"; 9820 print XREGEXP "$Xre\n"; 9821 close (XREGEXP); 9822 9823 gp_message ("debug", $subr_name, "wrote file $noPCfile.c.regex"); 9824 gp_message ("debugXL", $subr_name, "on return Xre = $Xre"); 9825 gp_message ("debugXL", $subr_name, "on return re = $re"); 9826 9827 return ($re); 9828 9829} #-- End of subroutine name_regex 9830 9831#------------------------------------------------------------------------------- 9832# TBD 9833#------------------------------------------------------------------------------- 9834sub nosrc 9835{ 9836 my $subr_name = get_my_name (); 9837 9838 my ($input_string) = @_; 9839 9840 my $directory_name = append_forward_slash ($input_string); 9841 my $LANG = $g_locale_settings{"LANG"}; 9842 my $result_file = $directory_name."no_source.html"; 9843 9844 gp_message ("debug", $subr_name, "result_file = $result_file"); 9845 9846 open (NS, ">", $result_file) 9847 or die ("$subr_name: cannot open file $result_file for writing - '$!'"); 9848 9849 print NS "<!doctype html public \"-//w3c//dtd html 3.2//en\">\n<html lang=\"$LANG\">\n<head>\n". 9850 "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" . 9851 "<title>No source</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."><pre>\n"; 9852 print NS "<a name=\"line1\"></a><font color=#C80707>"."No source was found"."</font>\n"; # red font 9853 print NS "</pre>\n<pre>Output generated by $version_info</pre>\n"; 9854 print NS "</body></html>\n"; 9855 9856 close (NS); 9857 9858 return (0); 9859 9860} #-- End of subroutine nosrc 9861 9862#------------------------------------------------------------------------------ 9863# TBD. 9864#------------------------------------------------------------------------------ 9865sub numerically 9866{ 9867 my $f1; 9868 my $f2; 9869 9870 if ($a =~ /^([^\d]*)(\d+)/) 9871 { 9872 $f1 = int ($2); 9873 if ($b=~ /^([^\d]*)(\d+)/) 9874 { 9875 $f2 = int ($2); 9876 $f1 == $f2 ? 0 : ($f1 < $f2 ? -1 : +1); 9877 } 9878 } 9879 else 9880 { 9881 return ($a <=> $b); 9882 } 9883} #-- End of subroutine numerically 9884 9885#------------------------------------------------------------------------------ 9886# Parse the user options. Also perform a basic check. More checks and also 9887# some specific to the option will be performed after this subroutine. 9888#------------------------------------------------------------------------------ 9889sub parse_and_check_user_options 9890{ 9891 my $subr_name = get_my_name (); 9892 9893 my ($no_of_args_ref, $option_list_ref) = @_; 9894 9895 my $no_of_args = ${ $no_of_args_ref }; 9896 my @option_list = @{ $option_list_ref }; 9897 9898 my @exp_dir_list; 9899 9900 my $arg; 9901 my $calltree_value; 9902 my $debug_value; 9903 my $default_metrics_value; 9904 my $func_limit_value; 9905 my $found_exp_dir = $FALSE; 9906 my $ignore_metrics_value; 9907 my $ignore_value; 9908 my $message; 9909 my $outputdir_value; 9910 my $quiet_value; 9911 my $hp_value; 9912 my $valid; 9913 my $verbose_value; 9914 9915 $no_of_args++; 9916 9917 gp_message ("debug", $subr_name, "no_of_args = $no_of_args"); 9918 gp_message ("debug", $subr_name, "option_list = @option_list"); 9919 9920 my $option_errors = 0; 9921 9922 while (defined ($arg = shift @ARGV)) 9923 { 9924 gp_message ("debug", $subr_name, "parsing options arg = $arg"); 9925 gp_message ("debug", $subr_name, "parsing options \@ARGV = @ARGV"); 9926 9927#------------------------------------------------------------------------------ 9928# The gprofng driver adds this option. We need to get rid of it. 9929#------------------------------------------------------------------------------ 9930 next if ($arg eq "--whoami=gprofng display html"); 9931 9932#------------------------------------------------------------------------------ 9933# Parse the input options and check for the values to be valid. 9934# 9935# Valid values are stored in the main option table. 9936# 9937# TBD: The early check handles some of these already and the duplicates 9938# can be removed. Be aware of some global settings though. 9939#------------------------------------------------------------------------------ 9940 if ($arg eq "--version") 9941 { 9942 print_version_info (); 9943 exit (0); 9944 } 9945 elsif ($arg eq "--help") 9946 { 9947 $ignore_value = print_help_info (); 9948 exit (0); 9949 } 9950 elsif (($arg eq "-v") or ($arg eq "--verbose")) 9951 { 9952 $verbose_value = shift @ARGV; 9953 $valid = check_user_option ("verbose", $verbose_value); 9954 if (not $valid) 9955 { 9956 $option_errors++; 9957 } 9958 else 9959 { 9960 $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? $TRUE : $FALSE; 9961 } 9962 next; 9963 } 9964 elsif (($arg eq "-w") or ($arg eq "--warnings")) 9965 { 9966 my $warnings_value = shift @ARGV; 9967 $valid = check_user_option ("warnings", $warnings_value); 9968 if (not $valid) 9969 { 9970 $option_errors++; 9971 } 9972 else 9973 { 9974 $g_warnings = $g_user_settings{"warnings"}{"current_value"} eq "on" ? $TRUE : $FALSE; 9975 } 9976 next; 9977 } 9978 elsif (($arg eq "-d") or ($arg eq "--debug")) 9979 { 9980 $debug_value = shift @ARGV; 9981 $valid = check_user_option ("debug", $debug_value); 9982 if (not $valid) 9983 { 9984 $option_errors++; 9985 } 9986 else 9987 { 9988#------------------------------------------------------------------------------ 9989# This function internally converts the value to uppercase. 9990#------------------------------------------------------------------------------ 9991 my $ignore_value = set_debug_size (\$debug_value); 9992 } 9993 next; 9994 } 9995 elsif (($arg eq "-q") or ($arg eq "--quiet")) 9996 { 9997 $quiet_value = shift @ARGV; 9998 $valid = check_user_option ("quiet", $quiet_value); 9999 10000 if (not $valid) 10001 { 10002 $option_errors++; 10003 } 10004 else 10005 { 10006 $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? $TRUE : $FALSE; 10007 } 10008 next; 10009 } 10010 elsif (($arg eq "-o") or ($arg eq "--output")) 10011 { 10012 $outputdir_value = shift @ARGV; 10013 $valid = check_user_option ("output", $outputdir_value); 10014 10015 if (not $valid) 10016 { 10017 $option_errors++; 10018 } 10019 10020 next; 10021 } 10022 elsif (($arg eq "-O") or ($arg eq "--overwrite")) 10023 { 10024 $outputdir_value = shift @ARGV; 10025 $valid = check_user_option ("overwrite", $outputdir_value); 10026 10027 if (not $valid) 10028 { 10029 $option_errors++; 10030 } 10031 10032 next; 10033 } 10034 elsif (($arg eq "-hp") or ($arg eq "--highlight-percentage")) 10035 { 10036 $hp_value = shift @ARGV; 10037 $valid = check_user_option ("highlight_percentage", $hp_value); 10038 10039 if (not $valid) 10040 { 10041 $option_errors++; 10042 } 10043 10044 next; 10045 } 10046# Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit")) 10047# Temporarily disabled { 10048# Temporarily disabled $func_limit_value = shift @ARGV; 10049# Temporarily disabled $valid = check_user_option ("func_limit", $func_limit_value); 10050# Temporarily disabled 10051# Temporarily disabled if (not $valid) 10052# Temporarily disabled { 10053# Temporarily disabled $option_errors++; 10054# Temporarily disabled } 10055# Temporarily disabled 10056# Temporarily disabled next; 10057# Temporarily disabled } 10058# Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree")) 10059# Temporarily disabled { 10060# Temporarily disabled $calltree_value = shift @ARGV; 10061# Temporarily disabled $valid = check_user_option ("calltree", $calltree_value); 10062# Temporarily disabled 10063# Temporarily disabled if (not $valid) 10064# Temporarily disabled { 10065# Temporarily disabled $option_errors++; 10066# Temporarily disabled } 10067# Temporarily disabled 10068# Temporarily disabled next; 10069# Temporarily disabled } 10070# Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage")) 10071# Temporarily disabled { 10072# Temporarily disabled $tp_value = shift @ARGV; 10073# Temporarily disabled $valid = check_user_option ("threshold_percentage", $tp_value); 10074# Temporarily disabled 10075# Temporarily disabled if (not $valid) 10076# Temporarily disabled { 10077# Temporarily disabled $option_errors++; 10078# Temporarily disabled } 10079# Temporarily disabled 10080# Temporarily disabled next; 10081# Temporarily disabled } 10082# Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics")) 10083# Temporarily disabled { 10084# Temporarily disabled $default_metrics_value = shift @ARGV; 10085# Temporarily disabled $valid = check_user_option ("default_metrics", $default_metrics_value); 10086# Temporarily disabled 10087# Temporarily disabled if (not $valid) 10088# Temporarily disabled { 10089# Temporarily disabled $option_errors++; 10090# Temporarily disabled } 10091# Temporarily disabled 10092# Temporarily disabled next; 10093# Temporarily disabled } 10094# Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics")) 10095# Temporarily disabled { 10096# Temporarily disabled $ignore_metrics_value = shift @ARGV; 10097# Temporarily disabled $valid = check_user_option ("ignore_metrics", $ignore_metrics_value); 10098# Temporarily disabled 10099# Temporarily disabled if (not $valid) 10100# Temporarily disabled { 10101# Temporarily disabled $option_errors++; 10102# Temporarily disabled } 10103# Temporarily disabled 10104# Temporarily disabled next; 10105# Temporarily disabled } 10106 else 10107 { 10108 10109#------------------------------------------------------------------------------ 10110# When we get to this part of the code it means that the current command line 10111# argument is not a known option. 10112# 10113# We check if it is the name of an experiment directory and if so, add it to 10114# the list with directories to use. 10115# 10116# If not, print an error message and increment the error variable because this 10117# is clearly something that is not right. 10118#------------------------------------------------------------------------------- 10119 10120 if ($arg =~ /^\-.*/) 10121 { 10122#------------------------------------------------------------------------------- 10123# It is an option, but not a supported one. Print a message and increment 10124# the error count. 10125#------------------------------------------------------------------------------- 10126 $message = "option $arg is not a known option"; 10127 push (@g_user_input_errors, $message); 10128 10129 $option_errors++; 10130 } 10131 else 10132 { 10133#------------------------------------------------------------------------------- 10134# Other than options, the input has to consist of at least one directory name. 10135# First remove any trailing slashes (/) and then check if the name is valid. 10136#------------------------------------------------------------------------------- 10137 $arg =~ s/\/*\/$//; 10138 if ($arg =~ /.+\.er$/) 10139 { 10140#------------------------------------------------------------------------------- 10141# It is the name of an experiment directory and is added to the list. 10142#------------------------------------------------------------------------------- 10143 $found_exp_dir = $TRUE; 10144 push (@exp_dir_list, $arg); 10145 } 10146 else 10147 { 10148#------------------------------------------------------------------------------- 10149# It is not a valid experiment directory name. Print a message and exit. 10150#------------------------------------------------------------------------------- 10151 $message = "not a valid experiment directory name: $arg"; 10152 push (@g_user_input_errors, $message); 10153 10154 $option_errors++; 10155 } 10156 } 10157 10158 } #-- End of last else 10159 10160 } #-- End of while-loop 10161 10162#------------------------------------------------------------------------------- 10163# Check if the name of the experiment directories is valid. Note that later 10164# we check for these directories to exist. 10165#------------------------------------------------------------------------------- 10166 if (not $found_exp_dir) 10167 { 10168 $message = "experiment directory name(s) are either not valid, or missing"; 10169 push (@g_user_input_errors, $message); 10170 10171 $option_errors++; 10172 } 10173 10174#------------------------------------------------------------------------------ 10175# Check for fatal errors to have occurred. If so, stop execution. Otherwise, 10176# confirm the verbose setting. 10177#------------------------------------------------------------------------------ 10178 if ($option_errors > 0) 10179 { 10180 gp_message ("debug", $subr_name, "a total of $option_errors input errors have been found"); 10181 } 10182 else 10183 { 10184 gp_message ("debug", $subr_name, "no errors in the options found"); 10185 } 10186 10187 return ($option_errors, $found_exp_dir, \@exp_dir_list); 10188 10189} #-- End of subroutine parse_and_check_user_options 10190 10191#------------------------------------------------------------------------------ 10192# Parse the generated .dis files 10193#------------------------------------------------------------------------------ 10194sub parse_dis_files 10195{ 10196 my $subr_name = get_my_name (); 10197 10198 my ($number_of_metrics_ref, $function_info_ref, 10199 $function_address_and_index_ref, $input_string_ref, 10200 $addressobj_index_ref) = @_; 10201 10202#------------------------------------------------------------------------------ 10203# Note that $function_address_and_index_ref is not used, but we need to pass 10204# in the address into generate_dis_html. 10205#------------------------------------------------------------------------------ 10206 my $number_of_metrics = ${ $number_of_metrics_ref }; 10207 my @function_info = @{ $function_info_ref }; 10208 my $input_string = ${ $input_string_ref }; 10209 my %addressobj_index = %{ $addressobj_index_ref }; 10210 10211#------------------------------------------------------------------------------ 10212# The regex section. 10213#------------------------------------------------------------------------------ 10214 my $dis_filename_id_regex = 'file\.([0-9]+)\.dis'; 10215 10216 my $filename; 10217 my $outputdir = append_forward_slash ($input_string); 10218 10219 my @source_line = (); 10220 my $source_line_ref; 10221 10222 my @metric = (); 10223 my $metric_ref; 10224 10225 my $target_function; 10226 10227 gp_message ("debug", $subr_name, "building disassembly files"); 10228 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 10229 10230 while (glob ($outputdir.'*.dis')) 10231 { 10232 gp_message ("debug", $subr_name, "processing disassembly file: $_"); 10233 10234 my $base_name = get_basename ($_); 10235 10236 if ($base_name =~ /$dis_filename_id_regex/) 10237 { 10238 if (defined ($1)) 10239 { 10240 gp_message ("debug", $subr_name, "processing disassembly file: $base_name $1"); 10241 if (exists ($function_info[$1]{"routine"})) 10242 { 10243 $target_function = $function_info[$1]{"routine"}; 10244 gp_message ("debug", $subr_name, "processing disassembly file: $base_name target_function = $target_function"); 10245 } 10246 if (exists ($g_function_tag_id{$target_function})) 10247 { 10248 gp_message ("debug", $subr_name, "target_function = $target_function ftag = $g_function_tag_id{$target_function}"); 10249 } 10250 else 10251 { 10252 my $msg = "no function tag found for $target_function"; 10253 gp_message ("assertion", $subr_name, $msg); 10254 } 10255 } 10256 else 10257 { 10258 gp_message ("debug", $subr_name, "processing disassembly file: $base_name unknown id"); 10259 } 10260 } 10261 10262 $filename = $_; 10263 gp_message ("verbose", $subr_name, " Processing disassembly file $filename"); 10264 ($source_line_ref, $metric_ref) = generate_dis_html ( 10265 \$target_function, 10266 \$number_of_metrics, 10267 $function_info_ref, 10268 $function_address_and_index_ref, 10269 \$outputdir, 10270 \$filename, 10271 \@source_line, 10272 \@metric, 10273 \%addressobj_index); 10274 10275 @source_line = @{ $source_line_ref }; 10276 @metric = @{ $metric_ref }; 10277 } 10278 10279 return (0) 10280 10281} #-- End of subroutine parse_dis_files 10282 10283#------------------------------------------------------------------------------ 10284# Parse the .src.txt files 10285#------------------------------------------------------------------------------ 10286sub parse_source_files 10287{ 10288 my $subr_name = get_my_name (); 10289 10290 my ($number_of_metrics_ref, $function_info_ref, $outputdir_ref) = @_; 10291 10292 my $number_of_metrics = ${ $number_of_metrics_ref }; 10293 my $outputdir = ${ $outputdir_ref }; 10294 my $ignore_value; 10295 10296 my $outputdir_with_slash = append_forward_slash ($outputdir); 10297 10298 gp_message ("verbose", $subr_name, "building source files"); 10299 10300 while (glob ($outputdir_with_slash.'*.src.txt')) 10301 { 10302 gp_message ("verbose", $subr_name, " Processing source file: $_"); 10303 gp_message ("debug", $subr_name, "processing source file: $_"); 10304 10305 my $found_target = process_source ( 10306 $number_of_metrics, 10307 $function_info_ref, 10308 $outputdir_with_slash, 10309 $_); 10310 10311 if (not $found_target) 10312 { 10313 gp_message ("debug", $subr_name, "target function not found"); 10314 } 10315 } 10316 10317} #-- End of subroutine parse_source_files 10318 10319#------------------------------------------------------------------------------ 10320# Routine to prepend \\ to selected symbols. 10321#------------------------------------------------------------------------------ 10322sub prepend_backslashes 10323{ 10324 my $subr_name = get_my_name (); 10325 10326 my ($target_string) = @_; 10327 10328 gp_message ("debug", $subr_name, "target_string on entry = $target_string"); 10329 10330 $target_string =~ s/\(/\\\(/g; 10331 $target_string =~ s/\)/\\\)/g; 10332 $target_string =~ s/\+/\\\+/g; 10333 $target_string =~ s/\[/\\\[/g; 10334 $target_string =~ s/\]/\\\]/g; 10335 $target_string =~ s/\*/\\\*/g; 10336 $target_string =~ s/\./\\\./g; 10337 $target_string =~ s/\$/\\\$/g; 10338 $target_string =~ s/\^/\\\^/g; 10339 $target_string =~ s/\#/\\\#/g; 10340 10341 gp_message ("debug", $subr_name, "target_string on return = $target_string"); 10342 10343 return ($target_string); 10344 10345} #-- End of subroutine prepend_backslashes 10346 10347#------------------------------------------------------------------------------ 10348# TBD 10349#------------------------------------------------------------------------------ 10350sub preprocess_function_files 10351{ 10352 my $subr_name = get_my_name (); 10353 10354 my ($metric_description_ref, $script_pc_metrics, $input_string, $sort_fields_ref) = @_; 10355 10356 my $outputdir = append_forward_slash ($input_string); 10357 my @sort_fields = @{ $sort_fields_ref }; 10358 10359 my $error_code; 10360 my $cmd_output; 10361 my $re; 10362 10363# TBD $outputdir .= "/"; 10364 10365 gp_message ("debug", $subr_name, "enter subroutine"); 10366 10367 my %metric_description = %{ $metric_description_ref }; 10368 10369 for my $m (keys %metric_description) 10370 { 10371 gp_message ("debug", $subr_name, "metric_description{$m} = $metric_description{$m}"); 10372 } 10373 10374 $re = name_regex ($metric_description_ref, $script_pc_metrics, "functions", $outputdir."functions.sort.func-PC"); 10375 ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."functions.sort.func-PC.name-regex"); 10376 if ($error_code != 0 ) 10377 { 10378 gp_message ("abort", $subr_name, "execution terminated"); 10379 } 10380 10381 for my $field (@sort_fields) 10382 { 10383 $re = name_regex ($metric_description_ref, $script_pc_metrics, $field, $outputdir."$field.sort.func-PC"); 10384 ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."$field.sort.func-PC.name-regex"); 10385 if ($error_code != 0 ) 10386 { 10387 gp_message ("abort", $subr_name, "execution terminated"); 10388 } 10389 } 10390 10391 $re = name_regex ($metric_description_ref, $script_pc_metrics, "calls", $outputdir."calls.sort.func-PC"); 10392 ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calls.sort.func-PC.name-regex"); 10393 if ($error_code != 0 ) 10394 { 10395 gp_message ("abort", $subr_name, "execution terminated"); 10396 } 10397 10398 if ($g_user_settings{"calltree"}{"current_value"} eq "on") 10399 { 10400 $re = name_regex ($metric_description_ref, $script_pc_metrics, "calltree", $outputdir."calltree.sort.func-PC"); 10401 ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calltree.sort.func-PC.name-regex"); 10402 if ($error_code != 0 ) 10403 { 10404 gp_message ("abort", $subr_name, "execution terminated"); 10405 } 10406 } 10407 10408 return (0); 10409 10410} #-- End of subroutine preprocess_function_files 10411 10412#------------------------------------------------------------------------------- 10413# Print the help overview 10414#------------------------------------------------------------------------------- 10415sub print_help_info 10416{ 10417 print 10418 #-------Marker line - do not go beyond this line ------------------------------ 10419 "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)\n". 10420 "\n". 10421 "Process one or more experiments to generate a directory containing the\n" . 10422 "index.html file that may be used to browse the experiment data.\n". 10423 "\n". 10424 "Options:\n". 10425 "\n". 10426 " --help print usage information and exit.\n". 10427 " --version print the version number and exit.\n". 10428 " --verbose {on|off} enable/disable verbose mode that shows diagnostic\n" . 10429 " messages about the processing of the data; default\n" . 10430 " is off.\n". 10431 #-------Marker line - do not go beyond this line ------------------------------ 10432 " -d, --debug {on|s|m|l|xl|off} control the printing of run time information\n" . 10433 " to assist with troubleshooting, or further\n" . 10434 " development of this tool; on gives a modest amount\n" . 10435 " of information; s, m, l, or xl gives an increasing\n" . 10436 " amount of information and off disables the printing\n" . 10437 " of debug information; note that currently on, s, m,\n" . 10438 " and l are equivalent; this is expected to change in\n" . 10439 " future updates; default is off.\n" . 10440 #-------Marker line - do not go beyond this line ------------------------------ 10441 " -hp, ----highlight-percentage <value> a percentage value in the interval\n" . 10442 " [0,100] to select and color code source\n" . 10443 " lines as well as instructions that are\n" . 10444 " within this percentage of the maximum\n" . 10445 " metric value(s); a value of zero (-hp 0)\n" . 10446 " disables this feature; the default is 90.\n". 10447 #-------Marker line - do not go beyond this line ------------------------------ 10448 " -o, --output <dir-name> use <dir-name> to store the results in; the\n" . 10449 " default name is ./display.<n>.html with <n> the\n" . 10450 " first positive integer number not in use; an\n" . 10451 " existing directory is not overwritten.\n". 10452 #-------Marker line - do not go beyond this line ------------------------------ 10453 " -O, --overwrite <dir-name> use <dir-name> to store the results in and\n" . 10454 " overwrite any existing directory with the\n" . 10455 " same name; make sure that umask is set to the\n" . 10456 " correct access permissions.\n" . 10457 #-------Marker line - do not go beyond this line ------------------------------ 10458 " -q, --quiet {on|off} disable/allow the display of all warning, debug and\n" . 10459 " verbose messages; if set to on, the settings for\n" . 10460 " verbose, warnings and debug are ignored; default\n" . 10461 " is off.\n". 10462 #-------Marker line - do not go beyond this line ------------------------------ 10463 " -w, --warnings {on|off} enable/disable run time warning messages;\n" . 10464 " default is on.\n". 10465 "\n". 10466# Temmporarily disabled " -fl, --func-limit <limit> impose a limit on the number of functions processed;\n". 10467# Temmporarily disabled " this is an integer number; set to 0 to process all\n". 10468# Temmporarily disabled " functions; the default value is 100.\n". 10469# Temmporarily disabled "\n". 10470# Temmporarily disabled " -ct, --calltree {on|off} enable or disable an html page with a call tree linked\n". 10471# Temmporarily disabled " from the bottom of the first page; default is off.\n". 10472# Temmporarily disabled "\n". 10473# Temmporarily disabled " -tp, --threshold-percentage <percentage> provide a percentage of metric accountability; the\n". 10474# Temmporarily disabled " inclusion of functions for each metric will take\n". 10475# Temmporarily disabled " place in sort order until the percentage has been\n". 10476# Temmporarily disabled " reached.\n". 10477# Temmporarily disabled "\n". 10478# Temmporarily disabled " -dm, --default-metrics {on|off} enable or disable automatic selection of metrics\n". 10479# Temmporarily disabled " and use a default set of metrics; the default is off.\n". 10480# Temmporarily disabled "\n". 10481# Temmporarily disabled " -im, --ignore-metrics <metric-list> ignore the metrics from <metric-list>.\n". 10482# Temmporarily disabled "\n". 10483# Temmporarily disabled "Environment:\n". 10484# Temmporarily disabled "\n". 10485# Temmporarily disabled "The options can be set in a configuration file called .gp-display-html.rc. This\n". 10486# Temmporarily disabled "file needs to be either in the current directory, or in the home directory of the user.\n". 10487# Temmporarily disabled "The long name of the option without the leading dashes is supported. For example calltree\n". 10488# Temmporarily disabled "to enable or disable the call tree. Note that some options take a value. In case the same option\n". 10489# Temmporarily disabled "occurs multiple times in this file, only the last setting encountered is preserved.\n". 10490# Temmporarily disabled "\n". 10491 "Documentation:\n". 10492 "\n". 10493 "A getting started guide for gprofng is maintained as a Texinfo manual.\n" . 10494 "If the info and gprofng programs are properly installed at your site,\n" . 10495 "the command \"info gprofng\" should give you access to this document.\n". 10496 "\n". 10497 "See also:\n". 10498 "\n". 10499 "gprofng(1), gp-archive(1), gp-collect-app(1), gp-display-src(1), " . 10500 "gp-display-text(1)\n"; 10501 10502 return (0); 10503 10504} #-- End of subroutine print_help_info 10505 10506#------------------------------------------------------------------------------- 10507# Print the meta data for each experiment directory. 10508#------------------------------------------------------------------------------- 10509sub print_meta_data_experiments 10510{ 10511 my $subr_name = get_my_name (); 10512 10513 my ($mode) = @_; 10514 10515 for my $exp (sort keys %g_exp_dir_meta_data) 10516 { 10517 for my $meta (sort keys %{$g_exp_dir_meta_data{$exp}}) 10518 { 10519 gp_message ($mode, $subr_name, "$exp => $meta = $g_exp_dir_meta_data{$exp}{$meta}"); 10520 } 10521 } 10522 10523 return (0); 10524 10525} #-- End of subroutine print_meta_data_experiments 10526 10527#------------------------------------------------------------------------------ 10528# Brute force subroutine that prints the contents of a structure with function 10529# level information. This version is for a top level array structure, 10530# followed by a hash. 10531#------------------------------------------------------------------------------ 10532sub print_metric_function_array 10533{ 10534 my $subr_name = get_my_name (); 10535 10536 my ($metric, $struct_type_name, $target_structure_ref) = @_; 10537 10538 my @target_structure = @{$target_structure_ref}; 10539 10540 gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:"); 10541 10542 for my $fields (sort keys @target_structure) 10543 { 10544 for my $elems (sort keys % {$target_structure[$fields]}) 10545 { 10546 my $msg = $struct_type_name."{$metric}[$fields]{$elems} = "; 10547 $msg .= $target_structure[$fields]{$elems}; 10548 gp_message ("debugXL", $subr_name, $msg); 10549 } 10550 } 10551 10552 return (0); 10553 10554} #-- End of subroutine print_metric_function_array 10555 10556#------------------------------------------------------------------------------ 10557# Brute force subroutine that prints the contents of a structure with function 10558# level information. This version is for a top level hash structure. The 10559# next level may be another hash, or an array. 10560#------------------------------------------------------------------------------ 10561sub print_metric_function_hash 10562{ 10563 my $subr_name = get_my_name (); 10564 10565 my ($sub_struct_type, $metric, $struct_type_name, $target_structure_ref) = @_; 10566 10567 my %target_structure = %{$target_structure_ref}; 10568 10569 gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:"); 10570 10571 for my $fields (sort keys %target_structure) 10572 { 10573 gp_message ("debugXL", $subr_name, "metric = $metric fields = $fields"); 10574 if ($sub_struct_type eq "hash_hash") 10575 { 10576 for my $elems (sort keys %{$target_structure{$fields}}) 10577 { 10578 my $txt = $struct_type_name."{$metric}{$fields}{$elems} = "; 10579 $txt .= $target_structure{$fields}{$elems}; 10580 gp_message ("debugXL", $subr_name, $txt); 10581 } 10582 } 10583 elsif ($sub_struct_type eq "hash_array") 10584 { 10585 my $values = ""; 10586 for my $elems (sort keys @{$target_structure{$fields}}) 10587 { 10588 $values .= "$target_structure{$fields}[$elems] "; 10589 } 10590 gp_message ("debugXL", $subr_name, $struct_type_name."{$metric}{$fields} = $values"); 10591 } 10592 else 10593 { 10594 my $msg = "sub-structure type '$sub_struct_type' is not supported"; 10595 gp_message ("assertion", $subr_name, $msg); 10596 } 10597 } 10598 10599 return (0); 10600 10601} #-- End of subroutine print_metric_function_hash 10602 10603#------------------------------------------------------------------------------ 10604# Print the opening message. 10605#------------------------------------------------------------------------------ 10606sub print_opening_message 10607{ 10608 my $subr_name = get_my_name (); 10609#------------------------------------------------------------------------------ 10610# Since the second argument is an array, we pass it in by reference. The 10611# alternative is to make it the last argument. 10612#------------------------------------------------------------------------------ 10613 my ($outputdir, $exp_dir_list_ref, $time_percentage_multiplier) = @_; 10614 10615 my @exp_dir_list = @{$exp_dir_list_ref}; 10616 10617 my $msg; 10618 my $no_of_dirs = scalar (@exp_dir_list); 10619#------------------------------------------------------------------------------ 10620# Build a comma separated list with all directory names. If there is only one 10621# entry, the leading comma will not be inserted. 10622#------------------------------------------------------------------------------ 10623 my $dir_list = join (", ", @exp_dir_list); 10624 10625#------------------------------------------------------------------------------ 10626# If there are at least two entries, find the last comma and replace it by 10627# " and". Note that we know there is at least one comma, so the value 10628# returned by rindex () cannot be -1. 10629#------------------------------------------------------------------------------ 10630 if ($no_of_dirs > 1) 10631 { 10632 my $last_comma = rindex ($dir_list, ","); 10633 my $ignore_value = substr ($dir_list, $last_comma, 1, " and"); 10634 } 10635 $msg = "start $tool_name, generating directory $outputdir from $dir_list"; 10636 10637 gp_message ("verbose", $subr_name, $msg); 10638 10639 if ($time_percentage_multiplier < 1.0) 10640 { 10641 $msg = "Handle at least "; 10642 } 10643 else 10644 { 10645 $msg = "Handle "; 10646 } 10647 10648 $msg .= ($time_percentage_multiplier*100.0)."% of the time"; 10649 10650 gp_message ("verbose", $subr_name, $msg); 10651 10652} #-- End of subroutine print_opening_message 10653 10654#------------------------------------------------------------------------------ 10655# TBD. 10656#------------------------------------------------------------------------------ 10657sub print_program_header 10658{ 10659 my $subr_name = get_my_name (); 10660 10661 my ($mode, $tool_name, $binutils_version) = @_; 10662 10663 my $header_limit = 60; 10664 my $dashes = "-"; 10665 10666#------------------------------------------------------------------------------ 10667# Generate the dashed line 10668#------------------------------------------------------------------------------ 10669 for (2 .. $header_limit) 10670 { 10671 $dashes .= "-"; 10672 } 10673 10674 gp_message ($mode, $subr_name, $dashes); 10675 gp_message ($mode, $subr_name, "Tool name: $tool_name"); 10676 gp_message ($mode, $subr_name, "Version : $binutils_version"); 10677 gp_message ($mode, $subr_name, "Date : " . localtime ()); 10678 gp_message ($mode, $subr_name, $dashes); 10679 10680} #-- End of subroutine print_program_header 10681 10682#------------------------------------------------------------------------------ 10683# Print a comment string, followed by the values of the options. The list 10684# with the keywords is sorted alphabetically. 10685# 10686# The value stored in $mode is passed on to gp_message (). The intended use 10687# for this is to call this function in verbose and/or debug mode. 10688# 10689# The comment string is converted to uppercase. 10690# 10691# In case the length of the comment exceeds the length of the dashed line, 10692# the comment line is allowed to stick out to the right. 10693# 10694# If the length of the comment is less than the dashed line, it is centered 10695# relative to the # length of the dashed line. 10696 10697# If the length of the comment and this line do not divide, an extra space is 10698# added to the left of the comment. 10699# 10700# For example, if the comment is 55 long, there are 5 spaces to be distributed. 10701# There will be 3 spaces, followed by the comment. 10702#------------------------------------------------------------------------------ 10703sub print_table_user_settings 10704{ 10705 my $subr_name = get_my_name (); 10706 10707 my ($mode, $comment) = @_; 10708 10709 my $leftover; 10710 my $padding; 10711 10712 my $keyword; 10713 my $user_option; 10714 my $defined; 10715 my $value; 10716 my $data_type; 10717 10718 my $HEADER_LIMIT = 60; 10719 my $header = sprintf ("%-20s %-9s %8s %s", "keyword", "option", "user set", "value"); 10720 10721#------------------------------------------------------------------------------ 10722# Generate the dashed line 10723#------------------------------------------------------------------------------ 10724 my $dashes = "-"; 10725 for (2 .. $HEADER_LIMIT) 10726 { 10727 $dashes .= "-"; 10728 } 10729 10730#------------------------------------------------------------------------------ 10731# Determine the padding needed to the left of the comment. 10732#------------------------------------------------------------------------------ 10733 my $length_comment = length ($comment); 10734 10735 $leftover = $length_comment%2; 10736 10737 if ($length_comment <= ($HEADER_LIMIT-2)) 10738 { 10739 $padding = ($HEADER_LIMIT - $length_comment + $leftover)/2; 10740 } 10741 else 10742 { 10743 $padding = 0; 10744 } 10745 10746#------------------------------------------------------------------------------ 10747# Generate the first blank part of the line. 10748#------------------------------------------------------------------------------ 10749 my $blank_line = ""; 10750 for (1 .. $padding) 10751 { 10752 $blank_line .= " "; 10753 } 10754 10755#------------------------------------------------------------------------------ 10756# Add the comment line with the first letter in uppercase. 10757#------------------------------------------------------------------------------ 10758 my $final_comment = $blank_line.ucfirst ($comment); 10759 10760 gp_message ($mode, $subr_name, $dashes); 10761 gp_message ($mode, $subr_name, $final_comment); 10762 gp_message ($mode, $subr_name, $dashes); 10763 gp_message ($mode, $subr_name, $header); 10764 gp_message ($mode, $subr_name, $dashes); 10765 10766#------------------------------------------------------------------------------ 10767# Print a line for each option. The list is sorted alphabetically. 10768#------------------------------------------------------------------------------ 10769 for my $rc_keyword (sort keys %g_user_settings) 10770 { 10771 $keyword = $rc_keyword; 10772 $user_option = $g_user_settings{$rc_keyword}{"option"}; 10773 $defined = ($g_user_settings{$rc_keyword}{"defined"} ? "set" : "not set"); 10774 $data_type = $g_user_settings{$rc_keyword}{"data_type"}; 10775 10776 if (defined ($g_user_settings{$rc_keyword}{"current_value"})) 10777 { 10778 $value = $g_user_settings{$rc_keyword}{"current_value"}; 10779 if ($data_type eq "boolean") 10780 { 10781 $value = $value ? "on" : "off"; 10782 } 10783 } 10784 else 10785 { 10786 $value = "undefined"; 10787 } 10788 10789 my $print_line = sprintf ("%-20s %-9s %8s %s", $keyword, $user_option, $defined, $value); 10790 10791 gp_message ($mode, $subr_name, $print_line); 10792 } 10793} #-- End of subroutine print_table_user_settings 10794 10795#------------------------------------------------------------------------------ 10796# Dump the contents of nested hash "g_user_settings". Some simple formatting 10797# is applied to make it easier to distinguish the various values. 10798#------------------------------------------------------------------------------ 10799sub print_user_settings 10800{ 10801 my $subr_name = get_my_name (); 10802 10803 my ($mode, $comment) = @_; 10804 10805 my $keyword_value_pair; 10806 10807 gp_message ($mode, $subr_name, $comment); 10808 10809 for my $rc_keyword (keys %g_user_settings) 10810 { 10811 my $print_line = sprintf ("%-20s =>", $rc_keyword); 10812 for my $fields (sort keys %{ $g_user_settings{$rc_keyword} }) 10813 { 10814 if (defined ($g_user_settings{$rc_keyword}{$fields})) 10815 { 10816 $keyword_value_pair = $fields." = ".$g_user_settings{$rc_keyword}{$fields}; 10817 } 10818 else 10819 { 10820 $keyword_value_pair = $fields." = ". "undefined"; 10821 } 10822 $print_line = join (" ", $print_line, $keyword_value_pair); 10823 } 10824 gp_message ($mode, $subr_name, $print_line); 10825 } 10826} #-- End of subroutine print_user_settings 10827 10828#------------------------------------------------------------------------------ 10829# Print the version number and license information. 10830#------------------------------------------------------------------------------ 10831sub print_version_info 10832{ 10833 print "$version_info\n"; 10834 print "Copyright (C) 2021 Free Software Foundation, Inc.\n"; 10835 print "License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>.\n"; 10836 print "This is free software: you are free to change and redistribute it.\n"; 10837 print "There is NO WARRANTY, to the extent permitted by law.\n"; 10838 10839 return (0); 10840 10841} #-- End of subroutine print_version_info 10842 10843#------------------------------------------------------------------------------ 10844# Process the call tree input data and generate HTML output. 10845#------------------------------------------------------------------------------ 10846sub process_calltree 10847{ 10848 my $subr_name = get_my_name (); 10849 10850 my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref, 10851 $input_string) = @_; 10852 10853 my @function_info = @{ $function_info_ref }; 10854 my %function_address_info = %{ $function_address_info_ref }; 10855 my %addressobjtextm = %{ $addressobjtextm_ref }; 10856 10857 my $outputdir = append_forward_slash ($input_string); 10858 10859 my @call_tree_data = (); 10860 10861 my $LANG = $g_locale_settings{"LANG"}; 10862 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 10863 10864 my $infile = $outputdir . "calltree"; 10865 my $outfile = $outputdir . "calltree.html"; 10866 10867 open (CALL_TREE_IN, "<", $infile) 10868 or die ("Not able to open calltree file $infile for reading - '$!'"); 10869 gp_message ("debug", $subr_name, "opened file $infile for reading"); 10870 10871 open (CALL_TREE_OUT, ">", $outfile) 10872 or die ("Not able to open $outfile for writing - '$!'"); 10873 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 10874 10875 gp_message ("debug", $subr_name, "building calltree file $outfile"); 10876 10877#------------------------------------------------------------------------------ 10878# The directory name is potentially used below, but since it is a constant, 10879# we get it here and only once. 10880#------------------------------------------------------------------------------ 10881# my ($ignore_file_name, $directory_name, $ignore_suffix) = fileparse ($infile,""); 10882# gp_message ("debug", $subr_name, "directory_name = $directory_name"); 10883 10884#------------------------------------------------------------------------------ 10885# Generate some of the structures used in the HTML output. 10886#------------------------------------------------------------------------------ 10887 my $file_title = "Call Tree overview"; 10888 my $html_header = ${ create_html_header (\$file_title) }; 10889 my $html_home_right = ${ generate_home_link ("right") }; 10890 10891 my $page_title = "Call Tree View"; 10892 my $size_text = "h2"; 10893 my $position_text = "center"; 10894 my $html_title_header = ${ generate_a_header ( 10895 \$page_title, 10896 \$size_text, 10897 \$position_text) }; 10898 10899#------------------------------------------------------------------------------- 10900# Get the acknowledgement, return to main link, and final html statements. 10901#------------------------------------------------------------------------------- 10902 my $html_home_left = ${ generate_home_link ("left") }; 10903 my $html_acknowledgement = ${ create_html_credits () }; 10904 my $html_end = ${ terminate_html_document () }; 10905 10906#------------------------------------------------------------------------------ 10907# Read all of the file into array with the name call_tree_data. 10908#------------------------------------------------------------------------------ 10909 chomp (@call_tree_data = <CALL_TREE_IN>); 10910 close (CALL_TREE_IN); 10911 10912#------------------------------------------------------------------------------ 10913#------------------------------------------------------------------------------ 10914# Process the data here and generate the HTML lines. 10915#------------------------------------------------------------------------------ 10916#------------------------------------------------------------------------------ 10917 10918#------------------------------------------------------------------------------ 10919# Print the top part of the HTML file. 10920#------------------------------------------------------------------------------ 10921 print CALL_TREE_OUT $html_header; 10922 print CALL_TREE_OUT $html_home_right; 10923 print CALL_TREE_OUT $html_title_header; 10924 10925#------------------------------------------------------------------------------- 10926# Print the generated HTML structures here. 10927#------------------------------------------------------------------------------- 10928## print CALL_TREE_OUT "$_" for @whatever; 10929## print CALL_TREE_OUT "<pre>\n"; 10930## print CALL_TREE_OUT "$_\n" for @whatever2; 10931## print CALL_TREE_OUT "</pre>\n"; 10932 10933#------------------------------------------------------------------------------- 10934# Print the last part of the HTML file. 10935#------------------------------------------------------------------------------- 10936 print CALL_TREE_OUT $html_home_left; 10937 print CALL_TREE_OUT "<br>\n"; 10938 print CALL_TREE_OUT $html_acknowledgement; 10939 print CALL_TREE_OUT $html_end; 10940 10941 close (CALL_TREE_OUT); 10942 10943 return (0); 10944 10945} #-- End of subroutine process_calltree 10946 10947#------------------------------------------------------------------------------- 10948# Process the generated experiment info file(s). 10949#------------------------------------------------------------------------------- 10950sub process_experiment_info 10951{ 10952 my $subr_name = get_my_name (); 10953 10954 my ($experiment_data_ref) = @_; 10955 10956 my @exp_info; 10957 my @experiment_data = @{ $experiment_data_ref }; 10958 10959 my $exp_id; 10960 my $exp_name; 10961 my $exp_data_file; 10962 my $input_line; 10963 my $target_cmd; 10964 my $hostname ; 10965 my $OS; 10966 my $page_size; 10967 my $architecture; 10968 my $start_date; 10969 my $end_experiment; 10970 my $data_collection_duration; 10971 my $total_thread_time; 10972 my $user_cpu_time; 10973 my $user_cpu_percentage; 10974 my $system_cpu_time; 10975 my $system_cpu_percentage; 10976 my $sleep_time; 10977 my $sleep_percentage; 10978 10979#------------------------------------------------------------------------------- 10980# Define the regular expressions used to capture the info. 10981#------------------------------------------------------------------------------- 10982# Target command (64-bit): './../bindir/mxv-pthreads.exe -m 3000 -n 2000 -t 2' 10983 10984 my $target_cmd_regex = '\s*Target command\s+(\(.+\)):\s+\'(.+)\''; 10985 10986# Host `ruudvan-vm-haswell-2-20210609', OS `Linux 5.4.17-2102.202.5.el8uek.x86_64', page size 4096, architecture `x86_64' 10987 10988 my $host_system_regex = '\s*Host\s+\`(.+)\',\s+OS\s+\`(.+)\',\s+page size\s+(\d+),\s+architecture\s+\`(.+)\''; 10989 10990# Experiment started Mon Aug 30 13:03:20 2021 10991 10992 my $start_date_regex = '\s*Experiment started\s+(.+)'; 10993 10994# Experiment Ended: 1.812441219 10995 10996 my $end_experiment_regex = '\s*Experiment Ended:\s+(.+)'; 10997 10998# Data Collection Duration: 1.812441219 10999 11000 my $data_collection_duration_regex = '\s*Data Collection Duration:\s+(.+)'; 11001 11002# Total Thread Time (sec.): 1.812 11003 11004 my $total_thread_time_regex = '\s*Total Thread Time (sec.):\s+(.+)'; 11005 11006# User CPU: 1.685 ( 95.0%) 11007 11008 my $user_cpu_regex = '\s*User CPU:\s+(.+)\s+\(\s*(.+)\)'; 11009 11010# System CPU: 0.088 ( 5.0%) 11011 11012 my $system_cpu_regex = '\s*System CPU:\s+(.+)\s+\(\s*(.+)\)'; 11013 11014# Sleep: 0. ( 0. %) 11015 11016 my $sleep_regex = '\s*Sleep:\s+(.+)\s+\(\s*(.+)\)'; 11017 11018#------------------------------------------------------------------------------- 11019# Scan the experiment data and select the info of interest. 11020#------------------------------------------------------------------------------- 11021 for my $i (sort keys @experiment_data) 11022 { 11023 $exp_id = $experiment_data[$i]{"exp_id"}; 11024 $exp_name = $experiment_data[$i]{"exp_name_full"}; 11025 $exp_data_file = $experiment_data[$i]{"exp_data_file"}; 11026 11027 my $msg = "exp_id = $exp_id name = $exp_name file = $exp_data_file"; 11028 gp_message ("debug", $subr_name, $msg); 11029 11030 open (EXPERIMENT_INFO, "<", $exp_data_file) 11031 or die ("$subr_name - unable to open file $exp_data_file for reading '$!'"); 11032 gp_message ("debug", $subr_name, "opened file $exp_data_file for reading"); 11033 11034 chomp (@exp_info = <EXPERIMENT_INFO>); 11035 11036#------------------------------------------------------------------------------- 11037# Process the info for the current experiment. 11038#------------------------------------------------------------------------------- 11039 for my $line (0 .. $#exp_info) 11040 { 11041 $input_line = $exp_info[$line]; 11042 11043 my $msg = "exp_id = $exp_id: input_line = $input_line"; 11044 gp_message ("debugM", $subr_name, $msg); 11045 11046 if ($input_line =~ /$target_cmd_regex/) 11047 { 11048 $target_cmd = $2; 11049 gp_message ("debugM", $subr_name, "$exp_id => $target_cmd"); 11050 $experiment_data[$i]{"target_cmd"} = $target_cmd; 11051 } 11052 elsif ($input_line =~ /$host_system_regex/) 11053 { 11054 $hostname = $1; 11055 $OS = $2; 11056 $page_size = $3; 11057 $architecture = $4; 11058 gp_message ("debugM", $subr_name, "$exp_id => $hostname $OS $page_size $architecture"); 11059 $experiment_data[$i]{"hostname"} = $hostname; 11060 $experiment_data[$i]{"OS"} = $OS; 11061 $experiment_data[$i]{"page_size"} = $page_size; 11062 $experiment_data[$i]{"architecture"} = $architecture; 11063 } 11064 elsif ($input_line =~ /$start_date_regex/) 11065 { 11066 $start_date = $1; 11067 gp_message ("debugM", $subr_name, "$exp_id => $start_date"); 11068 $experiment_data[$i]{"start_date"} = $start_date; 11069 } 11070 elsif ($input_line =~ /$end_experiment_regex/) 11071 { 11072 $end_experiment = $1; 11073 gp_message ("debugM", $subr_name, "$exp_id => $end_experiment"); 11074 $experiment_data[$i]{"end_experiment"} = $end_experiment; 11075 } 11076 elsif ($input_line =~ /$data_collection_duration_regex/) 11077 { 11078 $data_collection_duration = $1; 11079 gp_message ("debugM", $subr_name, "$exp_id => $data_collection_duration"); 11080 $experiment_data[$i]{"data_collection_duration"} = $data_collection_duration; 11081 } 11082#------------------------------------------------------------------------------ 11083# Start Label: Total 11084# End Label: Total 11085# Start Time (sec.): 0.000 11086# End Time (sec.): 1.812 11087# Duration (sec.): 1.812 11088# Total Thread Time (sec.): 1.812 11089# Average number of Threads: 1.000 11090# 11091# Process Times (sec.): 11092# User CPU: 1.666 ( 91.9%) 11093# System CPU: 0.090 ( 5.0%) 11094# Trap CPU: 0. ( 0. %) 11095# User Lock: 0. ( 0. %) 11096# Data Page Fault: 0. ( 0. %) 11097# Text Page Fault: 0. ( 0. %) 11098# Kernel Page Fault: 0. ( 0. %) 11099# Stopped: 0. ( 0. %) 11100# Wait CPU: 0. ( 0. %) 11101# Sleep: 0.056 ( 3.1%) 11102#------------------------------------------------------------------------------ 11103 elsif ($input_line =~ /$total_thread_time_regex/) 11104 { 11105 $total_thread_time = $1; 11106 gp_message ("debugM", $subr_name, "$exp_id => $total_thread_time"); 11107 $experiment_data[$i]{"total_thread_time"} = $total_thread_time; 11108 } 11109 elsif ($input_line =~ /$user_cpu_regex/) 11110 { 11111 $user_cpu_time = $1; 11112 $user_cpu_percentage = $2; 11113 gp_message ("debugM", $subr_name, "$exp_id => $user_cpu_time $user_cpu_percentage"); 11114 $experiment_data[$i]{"user_cpu_time"} = $user_cpu_time . " (" . $user_cpu_percentage . ")"; 11115 $experiment_data[$i]{"user_cpu_percentage"} = $user_cpu_percentage; 11116 } 11117 elsif ($input_line =~ /$system_cpu_regex/) 11118 { 11119 $system_cpu_time = $1; 11120 $system_cpu_percentage = $2; 11121 gp_message ("debugM", $subr_name, "$exp_id => $system_cpu_time $system_cpu_percentage"); 11122 $experiment_data[$i]{"system_cpu_time"} = $system_cpu_time . " (" . $system_cpu_percentage . ")"; 11123 $experiment_data[$i]{"system_cpu_percentage"} = $system_cpu_percentage; 11124 } 11125 elsif ($input_line =~ /$sleep_regex/) 11126 { 11127 $sleep_time = $1; 11128 $sleep_percentage = $2; 11129 $experiment_data[$i]{"sleep_time"} = $sleep_time . " (" . $sleep_percentage . ")"; 11130 $experiment_data[$i]{"sleep_percentage"} = $sleep_percentage; 11131 11132 my $msg = "exp_id = $exp_id => sleep_time = $sleep_time " . 11133 "sleep_percentage = $sleep_percentage"; 11134 gp_message ("debugM", $subr_name, $msg); 11135 } 11136 } 11137 } 11138 11139 for my $keys (0 .. $#experiment_data) 11140 { 11141 for my $fields (sort keys %{ $experiment_data[$keys] }) 11142 { 11143 my $msg = "experiment_data[$keys]{$fields} = " . 11144 $experiment_data[$keys]{$fields}; 11145 gp_message ("debugM", $subr_name, $msg); 11146 } 11147 } 11148 11149 return (\@experiment_data); 11150 11151} #-- End of subroutine process_experiment_info 11152 11153#------------------------------------------------------------------------------ 11154# TBD 11155#------------------------------------------------------------------------------ 11156sub process_function_files 11157{ 11158 my $subr_name = get_my_name (); 11159 11160 my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier, 11161 $summary_metrics, $process_all_functions, $elf_loadobjects_found, 11162 $outputdir, $sort_fields_ref, $function_info_ref, 11163 $function_address_and_index_ref, $LINUX_vDSO_ref, 11164 $metric_description_ref, $elf_arch, $base_va_executable, 11165 $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_; 11166 11167 my $old_fsummary; 11168 my $total_attributed_time; 11169 my $current_attributed_time; 11170 my $value; 11171 11172 my @exp_dir_list = @{ $exp_dir_list_ref }; 11173 my @function_info = @{ $function_info_ref }; 11174 my %function_address_and_index = %{ $function_address_and_index_ref }; 11175 my @sort_fields = @{ $sort_fields_ref }; 11176 my %metric_description = %{ $metric_description_ref }; 11177 my %elf_rats = %{ $elf_rats_ref }; 11178 11179#------------------------------------------------------------------------------ 11180# The regex section. 11181# 11182# TBD: Remove the part regarding clones. Legacy. 11183#------------------------------------------------------------------------------ 11184 my $replace_quote_regex = '"/\"'; 11185 my $find_clone_regex = '^(.*)(\s+--\s+cloned\s+version\s+\[)([^]]+)(\])'; 11186 11187 my %addressobj_index = (); 11188 my %function_address_info = (); 11189 my $function_address_info_ref; 11190 11191 $outputdir = append_forward_slash ($outputdir); 11192 11193 my %functions_per_metric_indexes = (); 11194 my $functions_per_metric_indexes_ref; 11195 11196 my %functions_per_metric_first_index = (); 11197 my $functions_per_metric_first_index_ref; 11198 11199 my %routine_list = (); 11200 my %handled_routines = (); 11201 11202#------------------------------------------------------------------------------ 11203# TBD: Name cleanup needed. 11204#------------------------------------------------------------------------------ 11205 11206 my $number_of_metrics; 11207 my $expr_name; 11208 my $routine; 11209 my $tmp; 11210 my $loadobj; 11211 my $PCA; 11212 my $address_field; 11213 my $limit_txt; 11214 my $n_metrics_text; 11215 my $disfile; 11216 my $srcfile; 11217 my $RIN; 11218 my $gp_listings_cmd; 11219 my $gp_display_text_cmd; 11220 my $ignore_value; 11221 11222 my $result_file = $outputdir . "gp-listings.out"; 11223 my $gp_error_file = $outputdir . "gp-listings.err"; 11224 11225 my $convert_to_dot = $g_locale_settings{"convert_to_dot"}; 11226 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 11227 my $length_of_string = length ($outputdir); 11228 11229 $expr_name = join (" ", @exp_dir_list); 11230 11231 gp_message ("debug", $subr_name, "expr_name = $expr_name"); 11232 11233#------------------------------------------------------------------------------ 11234# Loop over the files in $outputdir. 11235#------------------------------------------------------------------------------ 11236 while (glob ($outputdir.'*.sort.func-PC')) 11237 { 11238 my $metric; 11239 my $infile; 11240 my $ignore_value; 11241 my $suffix_not_used; 11242 11243 $infile = $_; 11244 11245 ($metric, $ignore_value, $suffix_not_used) = fileparse ($infile, ".sort.func-PC"); 11246 11247 gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used"); 11248 gp_message ("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-"); 11249 11250 # Function_info creates the functions files from the PC ones 11251 # as well as culling PC and metric information 11252 11253 ($function_address_info_ref, 11254 $functions_per_metric_first_index_ref, 11255 $functions_per_metric_indexes_ref) = function_info ( 11256 $outputdir, 11257 $infile, 11258 $metric, 11259 $LINUX_vDSO_ref); 11260 11261 @{$function_address_info{$metric}} = @{$function_address_info_ref}; 11262 %{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref}; 11263 %{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref}; 11264 11265 $ignore_value = print_metric_function_array ($metric, 11266 "function_address_info", 11267 \@{$function_address_info{$metric}}); 11268 $ignore_value = print_metric_function_hash ("hash_hash", $metric, 11269 "functions_per_metric_first_index", 11270 \%{$functions_per_metric_first_index{$metric}}); 11271 $ignore_value = print_metric_function_hash ("hash_array", $metric, 11272 "functions_per_metric_indexes", 11273 \%{$functions_per_metric_indexes{$metric}}); 11274 } 11275 11276#------------------------------------------------------------------------------ 11277# Get header info for use in post processing er_html output 11278#------------------------------------------------------------------------------ 11279 gp_message ("debugXL", $subr_name, "get_hdr_info section"); 11280 11281 get_hdr_info ($outputdir, $outputdir."functions.sort.func"); 11282 11283 for my $field (@sort_fields) 11284 { 11285 get_hdr_info ($outputdir, $outputdir."$field.sort.func"); 11286 } 11287 11288#------------------------------------------------------------------------------ 11289# Caller-callee 11290#------------------------------------------------------------------------------ 11291 get_hdr_info ($outputdir, $outputdir."calls.sort.func"); 11292 11293#------------------------------------------------------------------------------ 11294# Calltree 11295#------------------------------------------------------------------------------ 11296 if ($g_user_settings{"calltree"}{"current_value"} eq "on") 11297 { 11298 get_hdr_info ($outputdir, $outputdir."calltree.sort.func"); 11299 } 11300 11301 gp_message ("debug", $subr_name, "process functions"); 11302 11303 my $scriptfile = $outputdir.'gp-script'; 11304 my $script_metrics = "$summary_metrics"; 11305 my $func_limit = $g_user_settings{"func_limit"}{"current_value"}; 11306 11307 open (SCRIPT, ">", $scriptfile) 11308 or die ("Unable to create script file $scriptfile - '$!'"); 11309 gp_message ("debug", $subr_name, "opened script file $scriptfile for writing"); 11310 11311 print SCRIPT "# limit $func_limit\n"; 11312 print SCRIPT "limit $func_limit\n"; 11313 print SCRIPT "# thread_select all\n"; 11314 print SCRIPT "thread_select all\n"; 11315 print SCRIPT "# metrics $script_metrics\n"; 11316 print SCRIPT "metrics $script_metrics\n"; 11317 11318 for my $metric (@sort_fields) 11319 { 11320 gp_message ("debug", $subr_name, "handling $metric->$metric_description{$metric}"); 11321 11322 $total_attributed_time = 0; 11323 $current_attributed_time = 0; 11324 11325 $value = $function_address_info{$metric}[0]{"metric_value"}; # <Total> 11326 if ($convert_to_dot) 11327 { 11328 $value =~ s/$decimal_separator/\./; 11329 } 11330 $total_attributed_time = $value; 11331 11332#------------------------------------------------------------------------------ 11333# start at 1 - skipping <Total> 11334#------------------------------------------------------------------------------ 11335 for my $INDEX (1 .. $#{$function_address_info{$metric}}) 11336 { 11337#------------------------------------------------------------------------------ 11338#Looking to handle at least 99% of the time - or what the user asked for 11339#------------------------------------------------------------------------------ 11340 $value = $function_address_info{$metric}[$INDEX]{"metric_value"}; 11341 $routine = $function_address_info{$metric}[$INDEX]{"routine"}; 11342 11343 gp_message ("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time"); 11344 gp_message ("debugXL", $subr_name, " (found routine $routine : value $value)"); 11345 11346 if ($convert_to_dot) 11347 { 11348 $value =~ s/$decimal_separator/\./; 11349 } 11350 11351 if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or 11352 ( ($total_attributed_time == 0) and ($value>0) ) or 11353 $process_all_functions) 11354 { 11355 $PCA = $function_address_info{$metric}[$INDEX]{"PC Address"}; 11356 11357 if (not exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA})) 11358 { 11359 gp_message ("debugXL", $subr_name, "not exists: functions_per_metric_first_index{$metric}{$routine}{$PCA}"); 11360 } 11361 if (not exists ($function_address_and_index{$routine}{$PCA})) 11362 { 11363 gp_message ("debugXL", $subr_name, "not exists: function_address_and_index{$routine}{$PCA}"); 11364 } 11365 11366 if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and 11367 exists ($function_address_and_index{$routine}{$PCA})) 11368 { 11369#------------------------------------------------------------------------------ 11370# handled_routines now contains $RI from "first_metric" (?) 11371#------------------------------------------------------------------------------ 11372 $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1; 11373 my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; 11374 if ($metric_description{$metric} =~ /Exclusive Total CPU Time/) 11375 { 11376 $routine_list{$routine} = 1 11377 } 11378 11379 gp_message ("debugXL", $subr_name, " $routine is candidate"); 11380 } 11381 else 11382 { 11383 die ("internal error for metric $metric and routine $routine"); 11384 } 11385 11386 $current_attributed_time += $value; 11387 } 11388 } 11389 } 11390#------------------------------------------------------------------------------ 11391# Sort numerically in ascending order. 11392#------------------------------------------------------------------------------ 11393 for my $routine_index (sort {$a <=> $b} keys %handled_routines) 11394 { 11395 $routine = $function_info[$routine_index]{"routine"}; 11396 gp_message ("debugXL", $subr_name, "routine_index = $routine_index routine = $routine"); 11397 next unless $routine_list{$routine}; 11398 11399# not used $source = $function_info[$routine_index]{"Source File"}; 11400 11401 $function_info[$routine_index]{"srcline"} = ""; 11402 $address_field = $function_info[$routine_index]{"addressobjtext"}; 11403 11404## $disfile = "file\.$routine_index\.dis"; 11405 $disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"}; 11406 $srcfile = ""; 11407 $srcfile = "file\.$routine_index\.src.txt"; 11408 11409#------------------------------------------------------------------------------ 11410# If the file is unknown, we can disassemble anyway and add disassembly 11411# to the script. 11412#------------------------------------------------------------------------------ 11413 print SCRIPT "# outfile $outputdir"."$disfile\n"; 11414 print SCRIPT "outfile $outputdir"."$disfile\n"; 11415#------------------------------------------------------------------------------ 11416# TBD: Legacy. Not sure why this is needed, but it won't harm things. I hope. 11417#------------------------------------------------------------------------------ 11418 $tmp = $routine; 11419 $tmp =~ s/$replace_quote_regex//g; 11420 print SCRIPT "# disasm \"$tmp\" $address_field\n"; 11421 print SCRIPT "disasm \"$tmp\" $address_field\n"; 11422 if ($srcfile=~/file/) 11423 { 11424 print SCRIPT "# outfile $outputdir"."$srcfile\n"; 11425 print SCRIPT "outfile $outputdir"."$srcfile\n"; 11426 print SCRIPT "# source \"$tmp\" $address_field\n"; 11427 print SCRIPT "source \"$tmp\" $address_field\n"; 11428 } 11429 11430 if ($routine =~ /$find_clone_regex/) 11431 { 11432 my ($clone_routine) = $1.$2.$3.$4; 11433 my ($clone) = $3; 11434 } 11435 } 11436 close SCRIPT; 11437 11438#------------------------------------------------------------------------------ 11439# Remember the number of handled routines depends on the limit setting passed 11440# to er_print together with the sorting order on the metrics, which usually results 11441# in different routines at the top. Thus $RIN below can be greater than the limit. 11442#------------------------------------------------------------------------------ 11443 11444 $RIN = scalar (keys %handled_routines); 11445 11446 if (!$func_limit) 11447 { 11448 $limit_txt = "unlimited"; 11449 } 11450 else 11451 { 11452 $limit_txt = $func_limit - 1; 11453 } 11454 11455 $number_of_metrics = scalar (@sort_fields); 11456 11457 $n_metrics_text = ($number_of_metrics == 1) ? "metric" : "metrics"; 11458 11459 gp_message ("debugXL", $subr_name, "built function list with $RIN functions"); 11460 gp_message ("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt"); 11461 11462# add ELF program header offset 11463 11464 for my $routine_index (sort {$a <=> $b} keys %handled_routines) 11465 { 11466 $routine = $function_info[$routine_index]{"routine"}; 11467 $loadobj = $function_info[$routine_index]{"Load Object"}; 11468 11469 gp_message ("debugXL", $subr_name, "routine = $routine loadobj = $loadobj elf_arch = $elf_arch"); 11470 11471 if ($loadobj ne '') 11472 { 11473 # <Truncated-stack> is associated with <Total>. Its load object is <Total> 11474 if ($loadobj eq "<Total>") 11475 { 11476 next; 11477 } 11478 # Have seen a routine called <Unknown>. Its load object is <Unknown> 11479 if ($loadobj eq "<Unknown>") 11480 { 11481 next; 11482 } 11483############################################################################### 11484## RUUD: The new approach gives a different result. Investigate this. 11485# 11486# Turns out the new code improves the result. The addresses are now correct 11487# and as a result, more ftag's are created later on. 11488############################################################################### 11489 gp_message ("debugXL", $subr_name, "before function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}"); 11490 11491 $function_info[$routine_index]{"addressobj"} += bigint::hex ( 11492 determine_base_va_address ( 11493 $executable_name, 11494 $base_va_executable, 11495 $loadobj, 11496 $routine)); 11497 $addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index; 11498 11499 gp_message ("debugXL", $subr_name, "after function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}"); 11500 gp_message ("debugXL", $subr_name, "after addressobj_index{function_info[$routine_index]{addressobj}} = $addressobj_index{$function_info[$routine_index]{'addressobj'}}"); 11501 } 11502 } 11503 11504#------------------------------------------------------------------------------ 11505# Get the disassembly and source code output. 11506#------------------------------------------------------------------------------ 11507 $gp_listings_cmd = "$GP_DISPLAY_TEXT -limit $func_limit -viewmode machine " . 11508 "-compare off -script $scriptfile $expr_name"; 11509 11510 $gp_display_text_cmd = "$gp_listings_cmd 1> $result_file 2>> $gp_error_file"; 11511 11512 gp_message ("debugXL", $subr_name,"gp_display_text_cmd = $gp_display_text_cmd"); 11513 11514 gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to produce disassembly and source code output"); 11515 11516 my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 11517 11518 if ($error_code != 0) 11519 { 11520 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 11521 $error_code, 11522 $gp_error_file); 11523 gp_message ("abort", "execution terminated"); 11524 } 11525 11526 return (\@function_info, \%function_address_info, \%addressobj_index); 11527 11528} #-- End of subroutine process_function_files 11529 11530#------------------------------------------------------------------------------ 11531# Process the information found in the function overview file passed in. 11532# 11533# Example input: 11534# 11535# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 11536# Functions sorted by metric: Exclusive Total CPU Time 11537# 11538# PC Addr. Name Excl. Excl. CPU Excl. Excl. Excl. Excl. 11539# Total Cycles Instructions Last-Level IPC CPI 11540# CPU sec. sec. Executed Cache Misses 11541# 1:0x00000000 <Total> 3.713 4.256 15396819712 27727992 1.577 0.634 11542# 2:0x000021ae mxv_core 3.532 4.116 14500538992 27527781 1.536 0.651 11543# 2:0x00001f7b init_data 0.070 0.084 64020034 200211 0.333 3.000 11544#------------------------------------------------------------------------------ 11545sub process_function_overview 11546{ 11547 my $subr_name = get_my_name (); 11548 11549 my ($metric_ref, $exp_type_ref, $summary_metrics_ref, $number_of_metrics_ref, 11550 $function_info_ref, $function_view_structure_ref, $overview_file_ref) = @_; 11551 11552 my $metric = ${ $metric_ref }; 11553 my $exp_type = ${ $exp_type_ref }; 11554 my $summary_metrics = ${ $summary_metrics_ref }; 11555 my $number_of_metrics = ${ $number_of_metrics_ref }; 11556 my @function_info = @{ $function_info_ref }; 11557 my %function_view_structure = %{ $function_view_structure_ref }; 11558 my $overview_file = ${ $overview_file_ref }; 11559 11560 my $all_metrics; 11561 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 11562 my $length_of_block; 11563 my $elements_in_name; 11564 my $full_hex_address; 11565 my $header_line; 11566 my $hex_address; 11567 my $html_line; 11568 my $input_line; 11569 my $name_regex; 11570 my $no_of_fields; 11571 my $metrics_length; 11572 my $missing_digits; 11573 my $remaining_part_header; 11574 my $routine; 11575 my $routine_length; 11576 my $scan_header = $FALSE; 11577 my $scan_function_data = $FALSE; 11578 my $string_length; 11579 my $total_header_lines; 11580 11581 my @address_field = (); 11582 my @fields = (); 11583 my @function_data = (); 11584 my @function_names = (); 11585 my @function_view_array = (); 11586 my @function_view_modified = (); 11587 my @header_lines = (); 11588 my @metrics_part = (); 11589 my @metric_values = (); 11590 11591#------------------------------------------------------------------------------ 11592# The regex section. 11593#------------------------------------------------------------------------------ 11594 my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)'; 11595 my $total_marker_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(<Total>)\s+(.*)'; 11596 my $empty_line_regex = '^\s*$'; 11597 my $catch_all_regex = '\s*(.*)'; 11598 my $get_hex_address_regex = '(\d+):0x(\S+)'; 11599 my $get_addr_offset_regex = '^@\d+:'; 11600 my $zero_dot_at_end_regex = '[\w0-9' . $decimal_separator . ']*(0' . $decimal_separator . '$)'; 11601 my $backward_slash_regex = '\/'; 11602 11603#------------------------------------------------------------------------------ 11604 if (is_file_empty ($overview_file)) 11605 { 11606 gp_message ("error", $subr_name, "assertion error: file $overview_file is empty"); 11607 } 11608 11609 open (FUNC_OVERVIEW, "<", $overview_file) 11610 or die ("$subr_name - unable to open file $overview_file for reading '$!'"); 11611 gp_message ("debug", $subr_name, "opened file $overview_file for reading"); 11612 11613 gp_message ("debug", $subr_name, "processing file for exp_type = $exp_type"); 11614 11615 gp_message ("debugM", $subr_name, "header_name_regex = $header_name_regex"); 11616 gp_message ("debugM", $subr_name, "total_marker_regex = $total_marker_regex"); 11617 gp_message ("debugM", $subr_name, "empty_line_regex = $empty_line_regex"); 11618 gp_message ("debugM", $subr_name, "catch_all_regex = $catch_all_regex"); 11619 gp_message ("debugM", $subr_name, "get_hex_address_regex = $get_hex_address_regex"); 11620 gp_message ("debugM", $subr_name, "get_addr_offset_regex = $get_addr_offset_regex"); 11621 gp_message ("debugM", $subr_name, "zero_dot_at_end_regex = $zero_dot_at_end_regex"); 11622 gp_message ("debugM", $subr_name, "backward_slash_regex = $backward_slash_regex"); 11623 11624#------------------------------------------------------------------------------ 11625# Read the input file into memory. 11626#------------------------------------------------------------------------------ 11627 chomp (@function_data = <FUNC_OVERVIEW>); 11628 gp_message ("debug", $subr_name, "read all of file $overview_file into memory"); 11629 11630#------------------------------------------------------------------------------- 11631# Parse the function view info and store the data. 11632#------------------------------------------------------------------------------- 11633 my $max_header_length = 0; 11634 my $max_metrics_length = 0; 11635 11636#------------------------------------------------------------------------------ 11637# Loop over all the lines. Extract the header, metric values, function names, 11638# and the addresses. 11639# 11640# This is also where the maximum lengths for the header and metric lines are 11641# computed. This is used to get the correct alignment in the HTML output. 11642#------------------------------------------------------------------------------ 11643 for (my $line = 0; $line <= $#function_data; $line++) 11644 { 11645 $input_line = $function_data[$line]; 11646 gp_message ("debugXL", $subr_name, "input_line = $input_line"); 11647 11648#------------------------------------------------------------------------------ 11649# The table header is assumed to start at the line that has "Name" in it. 11650# The header ends when we see the function name "<Total>". 11651#------------------------------------------------------------------------------ 11652 if ($input_line =~ /$header_name_regex/) 11653 { 11654 $scan_header = $TRUE; 11655 } 11656 elsif ($input_line =~ /$total_marker_regex/) 11657 { 11658 $scan_header = $FALSE; 11659 $scan_function_data = $TRUE; 11660 } 11661 11662 if ($scan_header) 11663 { 11664#------------------------------------------------------------------------------ 11665# This group is only defined for the first line of the header and $4 contains 11666# the remaining part of the line after "Name", without the leading spaces. 11667#------------------------------------------------------------------------------ 11668 if (defined ($4)) 11669 { 11670 $remaining_part_header = $4; 11671 my $msg = "remaining_part_header = $remaining_part_header"; 11672 gp_message ("debugXL", $subr_name, $msg); 11673 11674#------------------------------------------------------------------------------ 11675# Determine the maximum length of the header. This needs to be done before 11676# the HTML controls are added. 11677#------------------------------------------------------------------------------ 11678 my $header_length = length ($remaining_part_header); 11679 $max_header_length = max ($max_header_length, $header_length); 11680 11681#------------------------------------------------------------------------------ 11682# TBD Should change this and not yet include html in header_lines 11683#------------------------------------------------------------------------------ 11684 $html_line = "<b>" . $remaining_part_header . "</b>"; 11685 11686 push (@header_lines, $html_line); 11687 11688 gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length"); 11689 gp_message ("debugXL", $subr_name, "html_line = $html_line"); 11690 } 11691#------------------------------------------------------------------------------ 11692# Captures the subsequent header lines. Assume they exist. 11693#------------------------------------------------------------------------------ 11694 elsif ($input_line =~ /$catch_all_regex/) 11695 { 11696 $header_line = $1; 11697 gp_message ("debugXL", $subr_name, "header_line = $header_line"); 11698 11699 my $header_length = length ($header_line); 11700 $max_header_length = max ($max_header_length, $header_length); 11701 11702#------------------------------------------------------------------------------ 11703# TBD Should change this and not yet include html in header_lines 11704#------------------------------------------------------------------------------ 11705 $html_line = "<b>" . $header_line . "</b>"; 11706 11707 push (@header_lines, $html_line); 11708 11709 gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length"); 11710 gp_message ("debugXL", $subr_name, "html_line = $html_line"); 11711 } 11712 } 11713#------------------------------------------------------------------------------ 11714# This is a line with function data. 11715#------------------------------------------------------------------------------ 11716 if ($scan_function_data and (not ($input_line =~ /$empty_line_regex/))) 11717 { 11718 @fields = split (" ", $input_line); 11719 11720 $no_of_fields = $#fields + 1; 11721 $elements_in_name = $no_of_fields - $number_of_metrics - 1; 11722 11723 gp_message ("debugXL", $subr_name, "no_of_fields = $no_of_fields elements_in_name = $elements_in_name"); 11724 11725#------------------------------------------------------------------------------ 11726# TBD: Handle this better in case a function entry has more than 2 words. 11727# Build the regex dynamically and use eval to capture the correct group. 11728# CHECK CODE IN GENERATE_CALLER_CALLEE 11729#------------------------------------------------------------------------------ 11730 if ($elements_in_name == 1) 11731 { 11732 $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)'; 11733 } 11734 elsif ($elements_in_name == 2) 11735 { 11736 $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+((\S+)\s+(\S+))\s+(.*)'; 11737 } 11738 else 11739 { 11740 gp_message ("error", $subr_name, "assertion error: $elements_in_name elements in name exceeds limit"); 11741 } 11742 11743 if ($input_line =~ /$name_regex/) 11744 { 11745 $full_hex_address = $1; 11746 $routine = $2; 11747 11748 if ($elements_in_name == 1) 11749 { 11750 $all_metrics = $3; 11751 } 11752 elsif ($elements_in_name == 2) 11753 { 11754 $all_metrics = $5; 11755 } 11756 11757#------------------------------------------------------------------------------ 11758# In case the last metric is 0. only, we append 3 extra characters that 11759# represent zero. We cannot change the number to 0.000 though because that 11760# has a different interpretation than 0. 11761# In a later phase, the "ZZZ" symbol will be removed again, but for now it 11762# creates consistency in, for example, the length of the metrics part. 11763#------------------------------------------------------------------------------ 11764 if ($all_metrics =~ /$zero_dot_at_end_regex/) 11765 { 11766 if (defined ($1) ) 11767 { 11768#------------------------------------------------------------------------------ 11769# Somewhat overkill, but remove the leading "\" from the decimal separator 11770# in the debug print since it is used for internal purposes only. 11771#------------------------------------------------------------------------------ 11772 my $decimal_point = $decimal_separator; 11773 $decimal_point =~ s/$backward_slash_regex//; 11774 my $txt = "all_metrics = $all_metrics ended with 0"; 11775 $txt .= "$decimal_point ($decimal_separator)"; 11776 gp_message ("debugXL", $subr_name, $txt); 11777 11778 $all_metrics .= "ZZZ"; 11779 } 11780 } 11781 $metrics_length = length ($all_metrics); 11782 $max_metrics_length = max ($max_metrics_length, $metrics_length); 11783 gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length"); 11784 11785 if ($full_hex_address =~ /$get_hex_address_regex/) 11786 { 11787 $hex_address = "0x" . $2; 11788 } 11789 11790 push (@address_field, $hex_address); 11791 push (@metric_values, $all_metrics); 11792 11793#------------------------------------------------------------------------------ 11794# Record the function name "as is". Below we figure out what the final name 11795# should be in case there are multiple occurrences of the same name. 11796# 11797# The reason to decouple this is to avoid the code gets too complex here. 11798#------------------------------------------------------------------------------ 11799 push (@function_names, $routine); 11800 } 11801 } 11802 } #-- End of loop over the input lines 11803 11804#------------------------------------------------------------------------------ 11805# Store the maximum lengths for the header and metrics. 11806#------------------------------------------------------------------------------ 11807 gp_message ("debugXL", $subr_name, "final max_header_length = $max_header_length"); 11808 gp_message ("debugXL", $subr_name, "final max_metrics_length = $max_metrics_length"); 11809 11810 $function_view_structure{"max header length"} = $max_header_length; 11811 $function_view_structure{"max metrics length"} = $max_metrics_length; 11812 11813#------------------------------------------------------------------------------ 11814# Determine the final name for the functions and set up the HTML block. 11815#------------------------------------------------------------------------------ 11816 my @final_html_function_block = (); 11817 my @function_index_list = (); 11818 11819#------------------------------------------------------------------------------ 11820# First, an index list is built. If we are to index the functions in order of 11821# appearance in the function overview from 0 to n-1, the value of the array 11822# for index "i" is the index into the large "function_info" structure. This 11823# has the final name, the html function block, etc. 11824#------------------------------------------------------------------------------ 11825 11826#------------------------------------------------------------------------------ 11827## TBD: Use get_index_function_info??!! 11828#------------------------------------------------------------------------------ 11829 for my $i (keys @function_names) 11830 { 11831#------------------------------------------------------------------------------ 11832# Get the function name and the address from the function overview. The 11833# address is used to differentiate in case a function has multiple occurences. 11834#------------------------------------------------------------------------------ 11835 my $routine = $function_names[$i]; 11836 my $current_address = $address_field[$i]; 11837 11838 my $found_a_match = $FALSE; 11839 my $final_function_name; 11840 my $ref_index; 11841 11842#------------------------------------------------------------------------------ 11843# Check if there are duplicate entries for this function. If there are, use 11844# the address to find the right match in the function_info structure. 11845#------------------------------------------------------------------------------ 11846 gp_message ("debugXL", $subr_name, "$routine: first check for multiple occurrences"); 11847 if (exists ($g_multi_count_function{$routine})) 11848 { 11849 gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); 11850 for my $ref (keys @{ $g_map_function_to_index{$routine} }) 11851 { 11852 my $ref_index = $g_map_function_to_index{$routine}[$ref]; 11853 my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; 11854#------------------------------------------------------------------------------ 11855# The address has the following format: 6:0x0003af50, but we only need the 11856# part after the colon and remove the first part. 11857#------------------------------------------------------------------------------ 11858 $addr_offset =~ s/$get_addr_offset_regex//; 11859 11860 gp_message ("debugXL", $subr_name, "$routine: ref_index = $ref_index"); 11861 gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); 11862 gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); 11863 11864 if ($addr_offset eq $current_address) 11865#------------------------------------------------------------------------------ 11866# There is a match and we can store the index. 11867#------------------------------------------------------------------------------ 11868 { 11869 $found_a_match = $TRUE; 11870 push (@function_index_list, $ref_index); 11871 last; 11872 } 11873 } 11874 } 11875 else 11876 { 11877#------------------------------------------------------------------------------ 11878# This is the easy case. There is only one index value. We do check if the 11879# array element that contains it, exists. If this is not the case, something 11880# has gone horribly wrong earlier and we need to bail out. 11881#------------------------------------------------------------------------------ 11882 if (defined ($g_map_function_to_index{$routine}[0])) 11883 { 11884 $found_a_match = $TRUE; 11885 $ref_index = $g_map_function_to_index{$routine}[0]; 11886 push (@function_index_list, $ref_index); 11887 my $final_function_name = $function_info[$ref_index]{"routine"}; 11888 gp_message ("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name"); 11889 } 11890 } 11891 if (not $found_a_match) 11892#------------------------------------------------------------------------------ 11893# This should not happen. All we can do is print an error message and stop. 11894#------------------------------------------------------------------------------ 11895 { 11896 my $msg = "cannot find the index for $routine: found_a_match = "; 11897 $msg .= ($found_a_match == $TRUE) ? "TRUE" : "FALSE"; 11898 gp_message ("assertion", $subr_name, $msg); 11899 } 11900 } 11901 11902#------------------------------------------------------------------------------ 11903# The loop over all function names has completed and @function_index_list 11904# contains the index values into @function_info for the functions. 11905# 11906# All we now need to do is to retrieve the correct field(s) from the array. 11907#------------------------------------------------------------------------------ 11908 for my $i (keys @function_index_list) 11909 { 11910 my $index_for_function = $function_index_list[$i]; 11911 push (@final_html_function_block, $function_info[$index_for_function]{"html function block"}); 11912 } 11913 for my $i (keys @final_html_function_block) 11914 { 11915 my $txt = "final_html_function_block[$i] = $final_html_function_block[$i]"; 11916 gp_message ("debugXL", $subr_name, $txt); 11917 } 11918 11919#------------------------------------------------------------------------------ 11920# Since the numbers are right aligned, we know that any difference between the 11921# metric line length and the maximum must be caused by the first column. All 11922# we need to do is to prepend spaces in case of a difference. 11923# 11924# While we have the line with the metric values, we also replace ZZZ by 3 11925# spaces. 11926#------------------------------------------------------------------------------ 11927 for my $i (keys @metric_values) 11928 { 11929 if (length ($metric_values[$i]) < $max_metrics_length) 11930 { 11931 my $pad = $max_metrics_length - length ($metric_values[$i]); 11932 my $spaces = ""; 11933 for my $s (1 .. $pad) 11934 { 11935 $spaces .= " "; 11936 } 11937 $metric_values[$i] = $spaces . $metric_values[$i]; 11938 } 11939 $metric_values[$i] =~ s/ZZZ/ /g; 11940 } 11941 11942#------------------------------------------------------------------------------ 11943# Determine the column widths. The start and end index of the words in the 11944# input line are stored in elements 0 and 1 of @word_index_values. 11945# 11946# The assumption made is that the first digit of a metric value on the first 11947# line is left # aligned with the header text. These are the Total values 11948# and other than for some derived metrics, e.g. CPI, should be the largest. 11949# 11950# The positions of the start of the value is what we should then use for the 11951# word "(sort)" to start. 11952# 11953# For example: 11954# 11955# Excl. Excl. CPU Excl. Excl. Excl. Excl. 11956# Total Cycles Instructions Last-Level IPC CPI 11957# CPU sec. sec. Executed Cache Misses 11958# 174.664 179.250 175838403203 1166209617 0.428 2.339 11959#------------------------------------------------------------------------------ 11960 11961 my $foundit_ref; 11962 my $foundit; 11963 my @index_values = (); 11964 my $index_values_ref; 11965 11966#------------------------------------------------------------------------------ 11967# Search for "Excl." in the top row. The metric values are aligned with this 11968# word and we can use it to position "(sort)" in the last header line. 11969# 11970# In @index_values, we store the position(s) of "Excl." in the header line. 11971# If none can be found, an exception is raised because at least one should 11972# be there. 11973# 11974# TBD: Check if this can be done only once. 11975# ------------------------------------------------------------------------------ 11976 my $target_keyword = "Excl."; 11977 11978 ($foundit_ref, $index_values_ref) = find_keyword_in_string ( 11979 \$remaining_part_header, 11980 \$target_keyword); 11981 11982 $foundit = ${ $foundit_ref }; 11983 @index_values = @{ $index_values_ref }; 11984 11985 if ($foundit) 11986 { 11987 for my $i (keys @index_values) 11988 { 11989 my $txt = "index_values[$i] = $index_values[$i]"; 11990 gp_message ("debugXL", $subr_name, $txt); 11991 } 11992 } 11993 else 11994 { 11995 my $msg = "keyword $target_keyword not found in $remaining_part_header"; 11996 gp_message ("assertion", $subr_name, $msg); 11997 } 11998 11999# ------------------------------------------------------------------------------ 12000# Compute the number of spaces we need to add between the "(sort)" strings. 12001# 12002# For example: 12003# 12004# 01234567890123456789 12005# 12006# Excl. Excl. 12007# (sort) (sort) 12008# xxxxxxxx 12009# 12010# The number of spaces required is 14 - 6 = 8. 12011# 12012# The number of spaces to be added is stored in @padding_values. These are 12013# the spaces to be added before the occurrence of "(sort)". This is why the 12014# first padding value is 0. 12015# ------------------------------------------------------------------------------ 12016 12017# ------------------------------------------------------------------------------ 12018# TBD: This needs to be done only once. 12019# ------------------------------------------------------------------------------ 12020 my @padding_values = (); 12021 my $P_previous = 0; 12022 for my $i (keys @index_values) 12023 { 12024 my $L = $index_values[$i]; 12025 my $P = $L + length ("(sort)"); 12026 my $pad_spaces = $L - $P_previous; 12027 12028 push (@padding_values, $pad_spaces); 12029 12030 $P_previous = $P; 12031 } 12032 12033 for my $i (keys @padding_values) 12034 { 12035 my $txt = "padding_values[$i] = $padding_values[$i]"; 12036 gp_message ("debugXL", $subr_name, $txt); 12037 } 12038 12039#------------------------------------------------------------------------------ 12040# Build up the sort line. Mark the current metric and make sure the line is 12041# aligned with the header. 12042#------------------------------------------------------------------------------ 12043 my $sort_string = "(sort)"; 12044 my $length_sort_string = length ($sort_string); 12045 my $sort_line = ""; 12046 my @active_metrics = split (":", $summary_metrics); 12047 for my $i (0 .. $number_of_metrics-1) 12048 { 12049 my $pad = $padding_values[$i]; 12050 my $metric_value = $active_metrics[$i]; 12051 12052 my $spaces = ""; 12053 for my $s (1 .. $pad) 12054 { 12055 $spaces .= " "; 12056 } 12057 12058 gp_message ("debugXL", $subr_name, "i = $i metric_value = $metric_value pad = $pad"); 12059 12060 if ($metric_value eq $exp_type) 12061#------------------------------------------------------------------------------ 12062# The current metric should have a different background color. 12063#------------------------------------------------------------------------------ 12064 { 12065 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . 12066 "." . $metric_value . ".html' style='background-color:" . 12067 $g_html_color_scheme{"background_selected_sort"} . 12068 "\'><b>(sort)</b></a>"; 12069 } 12070 elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric)) 12071#------------------------------------------------------------------------------ 12072# Set the background color for the sort metric in the main function overview. 12073#------------------------------------------------------------------------------ 12074 { 12075 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . 12076 "." . $metric_value . ".html' style='background-color:" . 12077 $g_html_color_scheme{"background_selected_sort"} . 12078 "'><b>(sort)</b></a>"; 12079 } 12080 else 12081#------------------------------------------------------------------------------ 12082# Do not set a specific background for all other metrics. 12083#------------------------------------------------------------------------------ 12084 { 12085 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . 12086 "." . $metric_value . ".html'>(sort)</a>"; 12087 } 12088 12089#------------------------------------------------------------------------------ 12090# Prepend the spaces to ensure correct alignment with the rest of the header. 12091#------------------------------------------------------------------------------ 12092 $sort_line .= $spaces . $sort_string; 12093 } 12094 12095 push (@header_lines, $sort_line); 12096 12097#------------------------------------------------------------------------------ 12098# Print the final results for the header and metrics. 12099#------------------------------------------------------------------------------ 12100 for my $i (keys @header_lines) 12101 { 12102 gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]"); 12103 } 12104 for my $i (keys @metric_values) 12105 { 12106 gp_message ("debugXL", $subr_name, "metric_values[$i] = $metric_values[$i]"); 12107 } 12108 12109#------------------------------------------------------------------------------ 12110# Construct the lines for the function overview. 12111# 12112# TBD: We could eliminate two structures here because metric_values and 12113# final_html_function_block are only copied and the result stored. 12114#------------------------------------------------------------------------------ 12115 for my $i (keys @function_names) 12116 { 12117 push (@metrics_part, $metric_values[$i]); 12118 push (@function_view_array, $final_html_function_block[$i]); 12119 } 12120 12121 for my $i (0 .. $#function_view_array) 12122 { 12123 my $msg = "function_view_array[$i] = $function_view_array[$i]"; 12124 gp_message ("debugXL", $subr_name, $msg); 12125 } 12126#------------------------------------------------------------------------------ 12127# Element "function table" contains the array with all the function view data. 12128#------------------------------------------------------------------------------ 12129 $function_view_structure{"header"} = [@header_lines]; 12130 $function_view_structure{"metrics part"} = [@metrics_part]; 12131 $function_view_structure{"function table"} = [@function_view_array]; 12132 12133 return (\%function_view_structure); 12134 12135} #-- End of subroutine process_function_overview 12136 12137#------------------------------------------------------------------------------ 12138# TBD 12139#------------------------------------------------------------------------------ 12140sub process_metrics 12141{ 12142 my $subr_name = get_my_name (); 12143 12144 my ($input_string, $sort_fields_ref, $metric_description_ref, $ignored_metrics_ref) = @_; 12145 12146 my @sort_fields = @{ $sort_fields_ref }; 12147 my %metric_description = %{ $metric_description_ref }; 12148 my %ignored_metrics = %{ $ignored_metrics_ref }; 12149 12150 my $outputdir = append_forward_slash ($input_string); 12151 my $LANG = $g_locale_settings{"LANG"}; 12152 my $max_len = 0; 12153 my $metric_comment; 12154 12155 my ($imetricn,$outfile); 12156 my ($html_metrics_record,$imetric,$metric); 12157 12158 $html_metrics_record = 12159 "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" . 12160 "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" . 12161 "<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n"; 12162 12163 $outfile = $outputdir . "metrics.html"; 12164 12165 open (METRICSOUT, ">", $outfile) 12166 or die ("$subr_name - unable to open file $outfile for writing - '$!'"); 12167 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 12168 12169 for $metric (@sort_fields) 12170 { 12171 $max_len = max ($max_len, length ($metric)); 12172 gp_message ("debug", $subr_name, "sort_fields: metric = $metric max_len = $max_len"); 12173 } 12174 12175# TBD: Check this 12176# for $imetric (@IMETRICS) 12177 for $imetric (keys %ignored_metrics) 12178 { 12179 $max_len = max ($max_len, length ($imetric)); 12180 gp_message ("debug", $subr_name, "ignored_metrics imetric = $imetric max_len = $max_len"); 12181 } 12182 12183 $max_len++; 12184 12185 gp_message ("debug", $subr_name, "max_len = $max_len"); 12186 12187 $html_metrics_record .= "<p style=\"font-size:14px;color:red\"> Metrics used (".($#sort_fields + 1).")\n</p><p style=\"font-size:14px\">"; 12188 for $metric (@sort_fields) 12189 { 12190 my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; 12191 gp_message ("debug", $subr_name, "handling metric metric = $metric->$description"); 12192 $html_metrics_record .= " $metric".(' ' x ($max_len - length ($metric)))."$description\n"; 12193 } 12194 12195# $imetricn = scalar (keys %IMETRICS); 12196 $imetricn = scalar (keys %ignored_metrics); 12197 if ($imetricn) 12198 { 12199 $html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">"; 12200# for $imetric (sort keys %IMETRICS){ 12201 for $imetric (sort keys %ignored_metrics) 12202 { 12203 $metric_comment = "(inclusive, exclusive, and percentages)"; 12204 $html_metrics_record .= " $imetric".(' ' x ($max_len - length ($imetric))).$metric_comment."\n"; 12205 gp_message ("debug", $subr_name, "handling metric imetric = $imetric $metric_comment"); 12206 } 12207 } 12208 12209 print METRICSOUT $html_metrics_record; 12210 print METRICSOUT $g_html_credits_line; 12211 close (METRICSOUT); 12212 12213 gp_message ("debug", $subr_name, "closed metrics file $outfile"); 12214 12215 return (0); 12216 12217} #-- End of subroutine process_metrics 12218 12219#------------------------------------------------------------------------------- 12220# TBD 12221#------------------------------------------------------------------------------- 12222sub process_metrics_data 12223{ 12224 my $subr_name = get_my_name (); 12225 12226 my ($outfile1, $outfile2, $ignored_metrics_ref) = @_; 12227 12228 my %ignored_metrics = %{ $ignored_metrics_ref }; 12229 12230 my %metric_value = (); 12231 my %metric_description = (); 12232 my %metric_found = (); 12233 12234 my $user_metrics; 12235 my $system_metrics; 12236 my $wall_metrics; 12237 my $metric_spec; 12238 my $metric_flavor; 12239 my $metric_visibility; 12240 my $metric_name; 12241 my $metric_text; 12242 my $metricdata; 12243 my $metric_line; 12244 12245 my $summary_metrics; 12246 my $detail_metrics; 12247 my $detail_metrics_system; 12248 my $call_metrics; 12249 12250 if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") 12251 { 12252 gp_message ("debug", $subr_name, "g_user_settings{default_metrics}{current_value} = " . $g_user_settings{"default_metrics"}{"current_value"}); 12253 # get metrics 12254 12255 $summary_metrics=''; 12256 $detail_metrics=''; 12257 $detail_metrics_system=''; 12258 $call_metrics = ''; 12259 $user_metrics=0; 12260 $system_metrics=0; 12261 $wall_metrics=0; 12262 12263 my ($last_metric,$metric,$value,$i,$r); 12264 12265 open (METRICTOTALS, "<", $outfile2) 12266 or die ("Unable to open metric value data file $outfile2 for reading - '$!'"); 12267 gp_message ("debug", $subr_name, "opened $outfile2 to parse metric value data"); 12268 12269#------------------------------------------------------------------------------ 12270# Below an example of the file that has just been opened. The lines I marked 12271# with a * has been wrapped by my for readability. This is not the case in the 12272# file, but makes for a really long line. 12273# 12274# Also, the data comes from one PC experiment and two HWC experiments. 12275#------------------------------------------------------------------------------ 12276# <Total> 12277# Exclusive Total CPU Time: 32.473 (100.0%) 12278# Inclusive Total CPU Time: 32.473 (100.0%) 12279# Exclusive CPU Cycles: 23.586 (100.0%) 12280# " count: 47054706905 12281# Inclusive CPU Cycles: 23.586 (100.0%) 12282# " count: 47054706905 12283# Exclusive Instructions Executed: 54417033412 (100.0%) 12284# Inclusive Instructions Executed: 54417033412 (100.0%) 12285# Exclusive Last-Level Cache Misses: 252730685 (100.0%) 12286# Inclusive Last-Level Cache Misses: 252730685 (100.0%) 12287# * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: 12288# * Exclusive Cycles Per Instruction: 12289# * Inclusive Cycles Per Instruction: 12290# * Size: 0 12291# PC Address: 1:0x00000000 12292# Source File: (unknown) 12293# Object File: (unknown) 12294# Load Object: <Total> 12295# Mangled Name: 12296# Aliases: 12297#------------------------------------------------------------------------------ 12298 12299 while (<METRICTOTALS>) 12300 { 12301 $metricdata = $_; chomp ($metricdata); 12302 gp_message ("debug", $subr_name, "file metrictotals: $metricdata"); 12303 12304#------------------------------------------------------------------------------ 12305# Ignoring whitespace, search for any line with a ":" in it, followed by 12306# a number with or without a dot. So, an integer or floating-point number. 12307#------------------------------------------------------------------------------ 12308 if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/) 12309 { 12310 gp_message ("debug", $subr_name, " candidate => $metricdata"); 12311 $metric = $1; 12312 $value = $2; 12313 if ( ($metric eq "PC Address") or ($metric eq "Size")) 12314 { 12315 gp_message ("debug", $subr_name, " skipped => $metric $value"); 12316 next; 12317 } 12318 gp_message ("debug", $subr_name, " proceed => $metric $value"); 12319 if ($metric eq '" count') 12320#------------------------------------------------------------------------------ 12321# Hardware counter experiments have this info. Note that this line is not the 12322# first one to be encountered, so $last_metric has been defined already. 12323#------------------------------------------------------------------------------ 12324 { 12325 $metric = $last_metric." Count"; # we presume ....... 12326 gp_message ("debug", $subr_name, "last_metric = $last_metric metric = $metric"); 12327 } 12328 $i=index ($metricdata,":"); 12329 $r=rindex ($metricdata,":"); 12330 gp_message ("debug", $subr_name, "metricdata = $metricdata => i = $i r = $r"); 12331 if ($i == $r) 12332 { 12333 if ($value > 0) # Not interested in metrics contributing zero 12334 { 12335 $metric_value{$metric} = $value; 12336 gp_message ("debug", $subr_name, "archived metric_value{$metric} = $metric_value{$metric}"); 12337 # e.g. $metric_value{Exclusive Total Thread Time} = 302.562 12338 # e.g. $metric_value{Exclusive Instructions Executed} = 2415126222484 12339 } 12340 } 12341 else 12342#------------------------------------------------------------------------------ 12343# TBD This code deals with an old bug and may be removed. 12344#------------------------------------------------------------------------------ 12345 { # er_print bug - e.g. 12346# Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: Exclusive Cycles Per Instruction: Inclusive Cycles Per Instruction: Exclusive OpenMP Work Time: 162.284 (100.0%) 12347 gp_message ("debug", $subr_name, "metrictotals odd line:->$metricdata<-"); 12348 $r=rindex ($metricdata,":",$r-1); 12349 if ($r == -1) 12350 { # ignore 12351 gp_message ("debug", $subr_name, "metrictotals odd line ignored<-"); 12352 $last_metric = "foo"; 12353 next; 12354 } 12355 my ($good_part)=substr ($metricdata,$r+1); 12356 if ($good_part =~ /\s*(.*):\s+(\d+\.*\d*)/) 12357 { 12358 $metric = $1; 12359 $value = $2; 12360 if ($value>0) # Not interested in metrics contributing zero 12361 { 12362 $metric_value{$metric} = $value; 12363 my $msg = "metrictotals odd line rescued '$metric'=$value"; 12364 gp_message ("debug", $subr_name, $msg); 12365 } 12366 } 12367 } 12368#------------------------------------------------------------------------------ 12369# Preserve the current metric. 12370#------------------------------------------------------------------------------ 12371 $last_metric = $metric; 12372 } 12373 } 12374 close (METRICTOTALS); 12375 } 12376 12377 if (scalar (keys %metric_value) == 0) 12378#------------------------------------------------------------------------------ 12379# If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we 12380# blow up later. 12381# 12382# TBD: See if this can be handled differently. 12383#------------------------------------------------------------------------------ 12384 { 12385 $metric_value{"Exclusive Total CPU Time"} = 0; 12386 gp_message ("debug", $subr_name, "no metrics found and a stub was added"); 12387 } 12388 12389 for my $metric (sort keys %metric_value) 12390 { 12391 gp_message ("debug", $subr_name, "Stored metric_value{$metric} = $metric_value{$metric}"); 12392 } 12393 12394 gp_message ("debug", $subr_name, "proceed to process file $outfile1"); 12395 12396#------------------------------------------------------------------------------ 12397# Open and process the metrics file. 12398#------------------------------------------------------------------------------ 12399 open (METRICS, "<", $outfile1) 12400 or die ("Unable to open metrics file $outfile1: '$!'"); 12401 gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); 12402 12403#------------------------------------------------------------------------------ 12404# Parse the file. This is a typical example: 12405# 12406# Exp Sel Total 12407# === === ===== 12408# 1 all 2 12409# 2 all 1 12410# 3 all 2 12411# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name 12412# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 12413# Available metrics: 12414# Exclusive Total CPU Time: e.%totalcpu 12415# Inclusive Total CPU Time: i.%totalcpu 12416# Exclusive CPU Cycles: e.+%cycles 12417# Inclusive CPU Cycles: i.+%cycles 12418# Exclusive Instructions Executed: e+%insts 12419# Inclusive Instructions Executed: i+%insts 12420# Exclusive Last-Level Cache Misses: e+%llm 12421# Inclusive Last-Level Cache Misses: i+%llm 12422# Exclusive Instructions Per Cycle: e+IPC 12423# Inclusive Instructions Per Cycle: i+IPC 12424# Exclusive Cycles Per Instruction: e+CPI 12425# Inclusive Cycles Per Instruction: i+CPI 12426# Size: size 12427# PC Address: address 12428# Name: name 12429#------------------------------------------------------------------------------ 12430 while (<METRICS>) 12431 { 12432 $metric_line = $_; 12433 chomp ($metric_line); 12434 12435 gp_message ("debug", $subr_name, "processing line $metric_line"); 12436#------------------------------------------------------------------------------ 12437# The original regex has bugs because the line should not be allowed to start 12438# with a ":". So this is wrong: 12439# if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/)) 12440# 12441# This is better: 12442# if (($metric =~ /\s*(.+):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/)) 12443# 12444# In general, this regex has some potential issues and has been replaced by 12445# the one shown below. 12446# 12447# We select a line that does not start with "Current" and aside from whitespace 12448# starts with anything (although it should be a string with words only), 12449# followed by whitespace and either an "e" or "i". This is called the "flavor" 12450# and is followed by a visibility marker (.,+,%, or !) and a metric name. 12451#------------------------------------------------------------------------------ 12452# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){ 12453 12454 ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) = 12455 extract_metric_specifics ($metric_line); 12456 12457# if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/)) 12458 if ($metric_spec eq "skipped") 12459 { 12460 gp_message ("debug", $subr_name, "skipped line: $metric_line"); 12461 } 12462 else 12463 { 12464 gp_message ("debug", $subr_name, "line of interest: $metric_line"); 12465 12466 $metric_found{$metric_spec} = 1; 12467 12468 if ($g_user_settings{"ignore_metrics"}{"defined"}) 12469 { 12470 gp_message ("debug", $subr_name, "check for $metric_spec"); 12471 if (exists ($ignored_metrics{$metric_name})) 12472 { 12473 gp_message ("debug", $subr_name, "user asked to ignore metric $metric_name"); 12474 next; 12475 } 12476 } 12477 12478#------------------------------------------------------------------------------ 12479# This metric is not on the ignored list and qualifies, so store it. 12480#------------------------------------------------------------------------------ 12481 $metric_description{$metric_spec} = $metric_text; 12482 12483# TBD: add for other visibilities too, like + 12484 gp_message ("debug", $subr_name, "stored $metric_description{$metric_spec} = $metric_description{$metric_spec}"); 12485 12486 if ($metric_flavor ne "e") 12487 { 12488 gp_message ("debug", $subr_name, "metric $metric_spec is ignored"); 12489 } 12490 else 12491#------------------------------------------------------------------------------ 12492# Only the exclusive metrics are shown. 12493#------------------------------------------------------------------------------ 12494 { 12495 gp_message ("debug", $subr_name, "metric $metric_spec ($metric_text) is considered"); 12496 12497 if ($metric_spec =~ /user/) 12498 { 12499 $user_metrics = $TRUE; 12500 gp_message ("debug", $subr_name, "m: user_metrics set to TRUE"); 12501 } 12502 elsif ($metric_spec =~ /system/) 12503 { 12504 $system_metrics = $TRUE; 12505 gp_message ("debug", $subr_name, "m: system_metrics set to TRUE"); 12506 } 12507 elsif ($metric_spec =~ /wall/) 12508 { 12509 $wall_metrics = $TRUE; 12510 gp_message ("debug", $subr_name, "m: wall_metrics set to TRUE"); 12511 } 12512#------------------------------------------------------------------------------ 12513# TBD I don't see why these need to be skipped. Also, should be totalcpu. 12514#------------------------------------------------------------------------------ 12515 elsif (($metric_spec =~ /^e\.total$/) or ($metric_spec =~/^e\.total_cpu$/)) 12516 { 12517 # skip total thread time and total CPU time 12518 gp_message ("debug", $subr_name, "m: skip above"); 12519 } 12520 elsif (defined ($metric_value{$metric_text})) 12521 { 12522 gp_message ("debug", $subr_name, "Total attributed to this metric metric_value{$metric_text} = $metric_value{$metric_text}"); 12523 if ($summary_metrics ne '') 12524 { 12525 $summary_metrics = $summary_metrics.':'.$metric_spec; 12526 gp_message ("debug", $subr_name, "updated summary_metrics = $summary_metrics - 1"); 12527 if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/) 12528 { 12529 $detail_metrics = $detail_metrics.':'.$metric_spec; 12530 gp_message ("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1"); 12531 $detail_metrics_system = $detail_metrics_system.':'.$metric_spec; 12532 gp_message ("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1"); 12533 } 12534 else 12535 { 12536 gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); 12537 } 12538 } 12539 else 12540 { 12541 $summary_metrics = $metric_spec; 12542 gp_message ("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2"); 12543 if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/) 12544 { 12545 $detail_metrics = $metric_spec; 12546 gp_message ("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2"); 12547 $detail_metrics_system = $metric_spec; 12548 gp_message ("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2"); 12549 } 12550 else 12551 { 12552 gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); 12553 } 12554 } 12555 gp_message ("debug", $subr_name, " metric $metric_spec added"); 12556 } 12557 else 12558 { 12559 gp_message ("debug", $subr_name, "m: no want above metric was a 0 total"); 12560 } 12561 } 12562 } 12563 } 12564 12565 close METRICS; 12566 12567 if ($wall_metrics > 0) 12568 { 12569 gp_message ("debug", $subr_name,"m:wall_metrics set adding to summary_metrics"); 12570 $summary_metrics = "e.wall:".$summary_metrics; 12571 gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 3"); 12572 } 12573 12574 if ($system_metrics > 0) 12575 { 12576 gp_message ("debug", $subr_name,"m:system_metrics set adding to summary_metrics,call_metrics and detail_metrics_system"); 12577 $summary_metrics = "e.system:".$summary_metrics; 12578 $call_metrics = "i.system:".$call_metrics; 12579 $detail_metrics_system ='e.system:'.$detail_metrics_system; 12580 12581 gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 4"); 12582 gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics"); 12583 gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 3"); 12584 } 12585 12586 12587#------------------------------------------------------------------------------ 12588# TBD: e.user and i.user do not always exist!! 12589#------------------------------------------------------------------------------ 12590 12591 if ($user_metrics > 0) 12592 { 12593 gp_message ("debug", $subr_name,"m:user_metrics set adding to summary_metrics,detail_metrics,detail_metrics_system and call_metrics"); 12594# Ruud if (!exists ($IMETRICS{"i.user"})){ 12595 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) 12596 { 12597 $summary_metrics = "e.user:".$summary_metrics; 12598 } 12599 else 12600 { 12601 $summary_metrics = "e.user:i.user:".$summary_metrics; 12602 } 12603 $detail_metrics = "e.user:".$detail_metrics; 12604 $detail_metrics_system = "e.user:".$detail_metrics_system; 12605 12606 gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 5"); 12607 gp_message ("debug", $subr_name,"m:detail_metrics=$detail_metrics - 3"); 12608 gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 4"); 12609 12610 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) 12611 { 12612 $call_metrics = "a.user:".$call_metrics; 12613 } 12614 else 12615 { 12616 $call_metrics = "a.user:i.user:".$call_metrics; 12617 } 12618 gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 2"); 12619 } 12620 12621 if ($call_metrics eq "") 12622 { 12623 $call_metrics = $detail_metrics; 12624 12625 gp_message ("debug", $subr_name,"m:call_metrics is not set, setting it to detail_metrics "); 12626 gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 3"); 12627 } 12628 12629 for my $metric (sort keys %ignored_metrics) 12630 { 12631 if ($ignored_metrics{$metric}) 12632 { 12633 gp_message ("debug", $subr_name, "active metric, but ignored: $metric"); 12634 } 12635 12636 } 12637 12638 return (\%metric_value, \%metric_description, \%metric_found, $user_metrics, $system_metrics, $wall_metrics, 12639 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics); 12640 12641} #-- End of subroutine process_metrics_data 12642 12643#------------------------------------------------------------------------------ 12644# Process source lines that are not part of the target function. 12645# 12646# Generate straightforward HTML, but define an anchor based on the source line 12647# number in the list. 12648#------------------------------------------------------------------------------ 12649sub process_non_target_source 12650{ 12651 my $subr_name = get_my_name (); 12652 12653 my ($start_scan, $end_scan, 12654 $src_times_regex, $function_regex, $number_of_metrics, 12655 $file_contents_ref, $modified_html_ref) = @_; 12656 12657 my @file_contents = @{ $file_contents_ref }; 12658 my @modified_html = @{ $modified_html_ref }; 12659 my $colour_code_line = $FALSE; 12660 my $input_line; 12661 my $line_id; 12662 my $modified_line; 12663 12664#------------------------------------------------------------------------------ 12665# Main loop to parse all of the source code and take action as needed. 12666#------------------------------------------------------------------------------ 12667 for (my $line_no=$start_scan; $line_no <= $end_scan; $line_no++) 12668 { 12669 $input_line = $file_contents[$line_no]; 12670 12671#------------------------------------------------------------------------------ 12672# Generate straightforward HTML, but define an anchor based on the source line 12673# number in the list. 12674#------------------------------------------------------------------------------ 12675 $line_id = extract_source_line_number ($src_times_regex, 12676 $function_regex, 12677 $number_of_metrics, 12678 $input_line); 12679 12680 if ($input_line =~ /$function_regex/) 12681 { 12682 $colour_code_line = $TRUE; 12683 } 12684 12685#------------------------------------------------------------------------------ 12686# We need to replace the "<" symbol in the code by "<". 12687#------------------------------------------------------------------------------ 12688 $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 12689 12690#------------------------------------------------------------------------------ 12691# Add an id. 12692#------------------------------------------------------------------------------ 12693 $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; 12694 12695 my $coloured_line; 12696 if ($colour_code_line) 12697 { 12698 my $boldface = $TRUE; 12699 $coloured_line = color_string ( 12700 $input_line, 12701 $boldface, 12702 $g_html_color_scheme{"non_target_function_name"}); 12703 $colour_code_line = $FALSE; 12704 $modified_line .= "$coloured_line"; 12705 } 12706 else 12707 { 12708 $modified_line .= "$input_line"; 12709 } 12710 gp_message ("debugXL", $subr_name, " $line_no : modified_line = $modified_line"); 12711 push (@modified_html, $modified_line); 12712 } 12713 12714 return (\@modified_html); 12715 12716} #-- End of subroutine process_non_target_source 12717 12718#------------------------------------------------------------------------------ 12719# This function scans the configuration file and adapts the internal settings 12720# accordingly. 12721# 12722# Errors are stored during the parsing and processing phase. They are printed 12723# at the end and sorted by line number. 12724#------------------------------------------------------------------------------ 12725sub process_rc_file 12726{ 12727 my $subr_name = get_my_name (); 12728 12729 my ($rc_file_name, $rc_file_paths_ref) = @_; 12730 12731#------------------------------------------------------------------------------ 12732# Local structures. 12733#------------------------------------------------------------------------------ 12734 my %rc_settings_user = (); #-- Store the values extracted from the config file 12735 my %error_and_warning_msgs = (); 12736 my @rc_file_paths = (); 12737 12738 my @split_line; 12739 my @my_fields; 12740 12741 my $message; 12742 my $first_part; 12743 my $line; 12744 my $line_number; 12745 my $number_of_fields; 12746 my $number_of_paths; 12747 my $parse_errors; #-- Count the number of errors 12748 my $parse_warnings; #-- Count the number of errors 12749 12750 my $rc_config_file; 12751 my $rc_file_found; 12752 my $rc_keyword; 12753 my $rc_value; 12754 12755 @rc_file_paths = @{$rc_file_paths_ref}; 12756 $number_of_paths = scalar (@rc_file_paths); 12757 12758 if ($number_of_paths == 0) 12759#------------------------------------------------------------------------------ 12760# This should not happen, but is a good safety net to add. 12761#------------------------------------------------------------------------------ 12762 { 12763 my $msg = "search path list is empty"; 12764 gp_message ("assertion", $subr_name, $msg); 12765 } 12766 12767#------------------------------------------------------------------------------ 12768# Check for the presence of a configuration file. 12769#------------------------------------------------------------------------------ 12770 gp_message ("debug", $subr_name, "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths"); 12771 12772 $rc_file_found = $FALSE; 12773 for my $path_name (@rc_file_paths) 12774 { 12775 $rc_config_file = $path_name . "/" . $rc_file_name; 12776 gp_message ("debug", $subr_name, "looking for configuration file $rc_config_file"); 12777 if (-f $rc_config_file) 12778 { 12779 gp_message ("debug", $subr_name, "found configuration file $rc_config_file"); 12780 $rc_file_found = $TRUE; 12781 last; 12782 } 12783 } 12784 12785 if (not $rc_file_found) 12786#------------------------------------------------------------------------------ 12787# There is no configuration file and we can skip this subroutine. 12788#------------------------------------------------------------------------------ 12789 { 12790 gp_message ("verbose", $subr_name, "Configuration file $rc_file_name not found"); 12791 return (0); 12792 } 12793 else 12794 { 12795 open (GP_DISPLAY_HTML_RC, "<", "$rc_config_file") 12796 or die ("$subr_name - unable to open file $rc_config_file for reading: $!"); 12797#------------------------------------------------------------------------------ 12798# The configuration file has been opened for reading. 12799#------------------------------------------------------------------------------ 12800 gp_message ("debug", $subr_name, "file $rc_config_file has been opened for reading"); 12801 } 12802 12803 gp_message ("verbose", $subr_name, "Found configuration file $rc_config_file"); 12804 gp_message ("debug", $subr_name, "processing configuration file $rc_config_file"); 12805 12806#------------------------------------------------------------------------------ 12807# Here we scan the configuration file for the settings. 12808# 12809# A setting consists of a keyword, optionally followed by a value. It is 12810# optional because not all keywords may require a value. 12811# 12812# At the end of this block, all keyword/value pairs are stored in a hash. 12813# 12814# We do not yet check for the validity of these pairs. This is done next. 12815# 12816# The original code had this all integrated, but it made the code very 12817# complex with deeply nested if-statements. The flow was also hard to follow. 12818#------------------------------------------------------------------------------ 12819 $parse_errors = 0; 12820 $parse_warnings = 0; 12821 $line_number = 0; 12822 while (my $line = <GP_DISPLAY_HTML_RC>) 12823 { 12824 chomp ($line); 12825 $line_number++; 12826 12827 gp_message ("debug", $subr_name, "read input line = $line"); 12828 12829#------------------------------------------------------------------------------ 12830# Ignore a line with whitespace only 12831#------------------------------------------------------------------------------ 12832 if ($line =~ /^\s*$/) 12833 { 12834 gp_message ("debug", $subr_name, "ignored a line with whitespace"); 12835 next; 12836 } 12837 12838#------------------------------------------------------------------------------ 12839# Ignore a comment line, defined by starting with a "#", possibly prepended by 12840# whitespace. 12841#------------------------------------------------------------------------------ 12842 if ($line =~ /^\s*\#/) 12843 { 12844 gp_message ("debug", $subr_name, "ignored a full comment line"); 12845 next; 12846 } 12847 12848#------------------------------------------------------------------------------ 12849# Split the input line using the "#" symbol as a separator. We have already 12850# handled the case of an isolated comment line, so there may only be an 12851# embedded comment. 12852# 12853# Regardless of this, we are only interested in the first part. 12854#------------------------------------------------------------------------------ 12855 @split_line = split ("#", $line); 12856 12857 for my $i (@split_line) 12858 { 12859 gp_message ("debug", $subr_name, "elements after split of line: $i"); 12860 } 12861 12862 $first_part = $split_line[0]; 12863 gp_message ("debug", $subr_name, "relevant part = $first_part"); 12864 12865 if ($first_part =~ /[&\^\*\@\$]+/) 12866#------------------------------------------------------------------------------ 12867# The &, ^, *, @ and $ symbols should not occur. If they do, we flag an error 12868# an fetch the next line. 12869#------------------------------------------------------------------------------ 12870 { 12871 $parse_errors++; 12872 $message = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line"; 12873 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; 12874 next; 12875 } 12876 else 12877#------------------------------------------------------------------------------ 12878# Split the first part on whitespace and verify the number of fields to be 12879# valid. Although we currently only have keywords with a value, a keyword 12880# without value is supported to. 12881# 12882# If the number of fields is valid, the keyword and value are stored. In case 12883# of a single field, the value is assigned a special string. 12884# 12885# Although this situation should not occur, we do abort if something unexpected 12886# is encountered here. 12887#------------------------------------------------------------------------------ 12888 { 12889 @my_fields = split (/\s/, $split_line[0]); 12890 12891 $number_of_fields = scalar (@my_fields); 12892 gp_message ("debug", $subr_name, "number of fields = $number_of_fields"); 12893 } 12894 12895 if ($number_of_fields ge 3) 12896#------------------------------------------------------------------------------ 12897# This is not supported. 12898#------------------------------------------------------------------------------ 12899 { 12900 $parse_errors++; 12901 $message = "more than 2 fields found: $first_part"; 12902 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; 12903 next; 12904 } 12905 elsif ($number_of_fields eq 2) 12906 { 12907 $rc_keyword = $my_fields[0]; 12908 $rc_value = $my_fields[1]; 12909 } 12910 elsif ($number_of_fields eq 1) 12911 { 12912 $rc_keyword = $my_fields[0]; 12913 $rc_value = "the_field_is_empty"; 12914 } 12915 else 12916 { 12917 my $msg = "[line $line_number] $rc_config_file - number of fields = $number_of_fields"; 12918 gp_message ("assertion", $subr_name, $msg); 12919 } 12920 12921#------------------------------------------------------------------------------ 12922# Store the keyword, value and line number. 12923#------------------------------------------------------------------------------ 12924 if (exists ($rc_settings_user{$rc_keyword})) 12925 { 12926 $parse_warnings++; 12927 my $prev_value = $rc_settings_user{$rc_keyword}{"value"}; 12928 my $prev_line_number = $rc_settings_user{$rc_keyword}{"line_no"}; 12929 if ($rc_value ne $prev_value) 12930 { 12931 $message = "option $rc_keyword previously set at line $prev_line_number: new value '$rc_value' overrides '$prev_value'"; 12932 } 12933 else 12934 { 12935 $message = "option $rc_keyword previously set to the same value at line $prev_line_number"; 12936 } 12937 $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $message; 12938 } 12939 $rc_settings_user{$rc_keyword}{"value"} = $rc_value; 12940 $rc_settings_user{$rc_keyword}{"line_no"} = $line_number; 12941 12942 gp_message ("debug", $subr_name, "stored keyword = $rc_keyword"); 12943 gp_message ("debug", $subr_name, "stored value = $rc_value"); 12944 gp_message ("debug", $subr_name, "stored line number = $line_number"); 12945 } 12946 12947#------------------------------------------------------------------------------ 12948# Completed the parsing of the configuration file. It can be closed. 12949#------------------------------------------------------------------------------ 12950 close (GP_DISPLAY_HTML_RC); 12951 12952#------------------------------------------------------------------------------ 12953# Print the raw input as just collected from the configuration file. 12954#------------------------------------------------------------------------------ 12955 gp_message ("debug", $subr_name, "contents of %rc_settings_user:"); 12956 for my $keyword (keys %rc_settings_user) 12957 { 12958 my $key_value = $rc_settings_user{$keyword}{"value"}; 12959 gp_message ("debug", $subr_name, "keyword = $keyword value = $key_value"); 12960 } 12961 12962 for my $rc_keyword (keys %g_user_settings) 12963 { 12964 for my $fields (keys %{ $g_user_settings{$rc_keyword} }) 12965 { 12966 gp_message ("debug", $subr_name, "before config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}"); 12967 } 12968 } 12969 12970#------------------------------------------------------------------------------ 12971# We are almost done. Check for all keywords found whether they are valid. 12972# Also verify that the corresponding value is valid. 12973# 12974# Update the g_user_settings table if everything is okay. 12975#------------------------------------------------------------------------------ 12976 12977 for my $rc_keyword (keys %rc_settings_user) 12978 { 12979 my $rc_value = $rc_settings_user{$rc_keyword}{"value"}; 12980 12981 if (exists ( $g_user_settings{$rc_keyword})) 12982 { 12983 12984#------------------------------------------------------------------------------ 12985# This is a supported keyword. There are two more things left to do: 12986# - Check how many values it requires (currently exactly one is supported) 12987# - Is the value a valid number or string? 12988#------------------------------------------------------------------------------ 12989 my $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"}; 12990 12991 if ($no_of_arguments eq 1) 12992 { 12993 my $input_value = $rc_value; 12994 if ($input_value ne "the_field_is_empty") 12995# 12996#------------------------------------------------------------------------------ 12997# So far, so good. We only need to check if the value is valid for the keyword. 12998#------------------------------------------------------------------------------ 12999 { 13000 my $data_type = $g_user_settings{$rc_keyword}{"data_type"}; 13001 my $valid_input = verify_if_input_is_valid ($input_value, $data_type); 13002#------------------------------------------------------------------------------ 13003# Check if the value is valid. 13004#------------------------------------------------------------------------------ 13005 if ($valid_input) 13006 { 13007 $g_user_settings{$rc_keyword}{"current_value"} = $rc_value; 13008 $g_user_settings{$rc_keyword}{"defined"} = $TRUE; 13009 } 13010 else 13011 { 13012 $parse_errors++; 13013 $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; 13014 $message = "input value '$input_value' for keyword $rc_keyword is not valid"; 13015 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; 13016 next; 13017 } 13018 } 13019 else 13020#------------------------------------------------------------------------------ 13021# This keyword requires a value, but none has been found. 13022#------------------------------------------------------------------------------ 13023 { 13024 $parse_errors++; 13025 $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; 13026 $message = "missing value for keyword '$rc_keyword'"; 13027 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; 13028 next; 13029 } 13030 } 13031 elsif ($no_of_arguments eq 0) 13032#------------------------------------------------------------------------------ 13033# Currently a theoretical scenario since all commands require a value, but in 13034# case this is no longer true, we need to at least flag the fact the user set 13035# this command. 13036#------------------------------------------------------------------------------ 13037 { 13038 $g_user_settings{$rc_keyword}{"defined"} = $TRUE; 13039 } 13040 else 13041#------------------------------------------------------------------------------ 13042# The code is not prepared for the situation one command has multiple values, 13043# but this situation should never occur. Still it won't hurt to add a check. 13044#------------------------------------------------------------------------------ 13045 { 13046 my $msg = "cannot handle $no_of_arguments in the input"; 13047 gp_message ("assertion", $subr_name, $msg); 13048 } 13049 } 13050 else 13051#------------------------------------------------------------------------------ 13052# A non-valid keyword is found. This is flagged as an error. 13053#------------------------------------------------------------------------------ 13054 { 13055 $parse_errors++; 13056 $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; 13057 $message = "keyword $rc_keyword is not supported"; 13058 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $message; 13059 } 13060 } 13061 for my $rc_keyword (keys %g_user_settings) 13062 { 13063 for my $fields (keys %{ $g_user_settings{$rc_keyword} }) 13064 { 13065 gp_message ("debug", $subr_name, "after config file: $rc_keyword $fields = $g_user_settings{$rc_keyword}{$fields}"); 13066 } 13067 } 13068 print_table_user_settings ("debug", "upon the return from $subr_name"); 13069 13070 if ( ($parse_errors == 0) and ($parse_warnings == 0) ) 13071 { 13072 gp_message ("verbose", $subr_name, "Successfully parsed and processed the configuration file"); 13073 } 13074 else 13075 { 13076 if ($parse_errors > 0) 13077 { 13078 my $plural_or_single = ($parse_errors > 1) ? "errors" : "error"; 13079 $message = $g_error_keyword . "found $parse_errors fatal $plural_or_single in the configuration file:"; 13080 gp_message ("debug", $subr_name, $message); 13081#------------------------------------------------------------------------------ 13082# Sort the hash keys, the line numbers, alphabetically and print the 13083# corresponding error messages. 13084#------------------------------------------------------------------------------ 13085 for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"error"} })) 13086 { 13087 $message = $g_error_keyword. "[line $line_no] in file $rc_config_file - "; 13088 $message .= $error_and_warning_msgs{"error"}{$line_no}{"message"}; 13089 gp_message ("debug", $subr_name, $message); 13090 } 13091 } 13092 13093 if (not $g_quiet) 13094 { 13095 if ($parse_warnings > 0) 13096 { 13097 $message = $g_warn_keyword . "found $parse_warnings warnings in the configuration file:"; 13098 gp_message ("debug", $subr_name, $message); 13099 for my $line_no (sort {$a <=> $b} (keys %{ $error_and_warning_msgs{"warning"} })) 13100 { 13101 $message = $g_warn_keyword . "[line $line_no] in file $rc_config_file - "; 13102 $message .= $error_and_warning_msgs{"warning"}{$line_no}{"message"}; 13103 gp_message ("debug", $subr_name, $message); 13104 } 13105 } 13106 } 13107 } 13108 13109 return ($parse_errors); 13110 13111} #-- End of subroutine process_rc_file 13112 13113#------------------------------------------------------------------------------ 13114# Generate the annotated html file for the source listing. 13115#------------------------------------------------------------------------------ 13116sub process_source 13117{ 13118 my $subr_name = get_my_name (); 13119 13120 my ($number_of_metrics, $function_info_ref, 13121 $outputdir, $input_filename) = @_; 13122 13123 my @function_info = @{ $function_info_ref }; 13124 13125#------------------------------------------------------------------------------ 13126# The regex section 13127#------------------------------------------------------------------------------ 13128 my $end_src1_header_regex = '(^\s+)(\d+)\.\s+(.*)'; 13129 my $end_src2_header_regex = '(^\s+)(<Function: )(.*)>'; 13130 my $function_regex = '^(\s*)<Function:\s(.*)>'; 13131 my $function2_regex = '^(\s*)<Function:\s(.*)>'; 13132 my $src_regex = '(\s*)(\d+)\.(.*)'; 13133 my $txt_ext_regex = '\.txt$'; 13134 my $src_filename_id_regex = '^file\.(\d+)\.src\.txt$'; 13135 my $integer_only_regex = '\d+'; 13136#------------------------------------------------------------------------------ 13137# Computed dynamically below. 13138# TBD: Try to move this up. 13139#------------------------------------------------------------------------------ 13140 my $src_times_regex; 13141 my $hot_lines_regex; 13142 my $metric_regex; 13143 my $metric_extra_regex; 13144 13145 my @components = (); 13146 my @fields_in_line = (); 13147 my @file_contents = (); 13148 my @hot_source_lines = (); 13149 my @max_metric_values = (); 13150 my @modified_html = (); 13151 my @transposed_hot_lines = (); 13152 13153 my $colour_coded_line; 13154 my $colour_coded_line_ref; 13155 my $line_id; 13156 my $ignore_value; 13157 my $func_name_in_src_file; 13158 my $html_new_line = "<br>"; 13159 my $input_line; 13160 my $metric_values; 13161 my $modified_html_ref; 13162 my $modified_line; 13163 my $is_empty; 13164 my $start_all_source; 13165 my $start_target_source; 13166 my $end_target_source; 13167 my $output_line; 13168 my $hot_line; 13169 my $src_line_no; 13170 my $src_code_line; 13171 13172 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 13173 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; 13174 13175 my $file_title; 13176 my $found_target; 13177 my $html_dis_record; 13178 my $html_end; 13179 my $html_header; 13180 my $html_home; 13181 my $rounded_percentage; 13182 my $start_tracking; 13183 my $threshold_line; 13184 13185 my $base; 13186 my $boldface; 13187 my $msg; 13188 my $routine; 13189 13190 my $LANG = $g_locale_settings{"LANG"}; 13191 my $the_title = set_title ($function_info_ref, $input_filename, 13192 "process source"); 13193 my $outfile = $input_filename . ".html"; 13194 13195#------------------------------------------------------------------------------ 13196# Remove the .txt from file.<n>.src.txt 13197#------------------------------------------------------------------------------ 13198 my $html_output_file = $input_filename; 13199 $html_output_file =~ s/$txt_ext_regex/.html/; 13200 13201 gp_message ("debug", $subr_name, "input_filename = $input_filename"); 13202 gp_message ("debug", $subr_name, "the_title = $the_title"); 13203 13204 $file_title = $the_title; 13205 $html_header = ${ create_html_header (\$file_title) }; 13206 $html_home = ${ generate_home_link ("right") }; 13207 13208 push (@modified_html, $html_header); 13209 push (@modified_html, $html_home); 13210 push (@modified_html, "<pre>"); 13211 13212#------------------------------------------------------------------------------ 13213# Open the html file used for the output. 13214#------------------------------------------------------------------------------ 13215 open (NEW_HTML, ">", $html_output_file) 13216 or die ("$subr_name - unable to open file $html_output_file for writing: '$!'"); 13217 gp_message ("debug", $subr_name , "opened file $html_output_file for writing"); 13218 13219 $base = get_basename ($input_filename); 13220 13221 gp_message ("debug", $subr_name, "base = $base"); 13222 13223 if ($base =~ /$src_filename_id_regex/) 13224 { 13225 my $file_id = $1; 13226 if (defined ($function_info[$file_id]{"routine"})) 13227 { 13228 $routine = $function_info[$file_id]{"routine"}; 13229 13230 gp_message ("debugXL", $subr_name, "target routine = $routine"); 13231 } 13232 else 13233 { 13234 my $msg = "cannot retrieve routine name for file_id = $file_id"; 13235 gp_message ("assertion", $subr_name, $msg); 13236 } 13237 } 13238 13239#------------------------------------------------------------------------------ 13240# Check if the input file is empty. If so, generate a short text in the html 13241# file and return. Otherwise open the file and read the contents. 13242#------------------------------------------------------------------------------ 13243 $is_empty = is_file_empty ($input_filename); 13244 13245 if ($is_empty) 13246 { 13247#------------------------------------------------------------------------------ 13248# The input file is empty. Write a diagnostic message in the html file and exit. 13249#------------------------------------------------------------------------------ 13250 gp_message ("debug", $subr_name ,"file $input_filename is empty"); 13251 13252 my $comment = "No source listing generated by $tool_name - " . 13253 "file $input_filename is empty"; 13254 my $error_file = $outputdir . "gp-listings.err"; 13255 13256 my $html_empty_file_ref = html_text_empty_file (\$comment, \$error_file); 13257 my @html_empty_file = @{ $html_empty_file_ref }; 13258 13259 print NEW_HTML "$_\n" for @html_empty_file; 13260 13261 close NEW_HTML; 13262 13263 return (0); 13264 } 13265 else 13266#------------------------------------------------------------------------------ 13267# Open the input file with the source code 13268#------------------------------------------------------------------------------ 13269 { 13270 open (SRC_LISTING, "<", $input_filename) 13271 or die ("$subr_name - unable to open file $input_filename for reading: '$!'"); 13272 gp_message ("debug", $subr_name, "opened file $input_filename for reading"); 13273 } 13274 13275#------------------------------------------------------------------------------ 13276# Generate the regex for the metrics. This depends on the number of metrics. 13277#------------------------------------------------------------------------------ 13278 gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator<--"); 13279 13280 $metric_regex = ''; 13281 $metric_extra_regex = ''; 13282 for my $metric_used (1 .. $number_of_metrics) 13283 { 13284 $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+'; 13285 } 13286 $metric_extra_regex = $metric_regex . '(\d+' . $decimal_separator . ')'; 13287 13288 $hot_lines_regex = '^(#{2})\s+'; 13289 $hot_lines_regex .= '('.$metric_regex.')'; 13290 $hot_lines_regex .= '([0-9?]+)\.\s+(.*)'; 13291 13292 $src_times_regex = '^(#{2}|\s{2})\s+'; 13293 $src_times_regex .= '('.$metric_extra_regex.')'; 13294 $src_times_regex .= '(.*)'; 13295 13296 gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex"); 13297 gp_message ("debugXL", $subr_name, "hot_lines_regex = $hot_lines_regex"); 13298 gp_message ("debugXL", $subr_name, "src_times_regex = $src_times_regex"); 13299 gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); 13300 13301 gp_message ("debugXL", $subr_name, "end_src1_header_regex = $end_src1_header_regex"); 13302 gp_message ("debugXL", $subr_name, "end_src2_header_regex = $end_src2_header_regex"); 13303 gp_message ("debugXL", $subr_name, "function_regex = $function_regex"); 13304 gp_message ("debugXL", $subr_name, "function2_regex = $function2_regex"); 13305 gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); 13306 13307#------------------------------------------------------------------------------ 13308# Read the file into memory. 13309#------------------------------------------------------------------------------ 13310 chomp (@file_contents = <SRC_LISTING>); 13311 13312#------------------------------------------------------------------------------ 13313# Identify the header lines. Make the minimal assumptions. 13314# 13315# In both cases, the first line after the header has whitespace. This is 13316# followed by either one of the following: 13317# 13318# - <line_no>. 13319# - <Function: 13320# 13321# These are the characteristics we use below. 13322#------------------------------------------------------------------------------ 13323 for (my $line_number=0; $line_number <= $#file_contents; $line_number++) 13324 { 13325 $input_line = $file_contents[$line_number]; 13326 13327#------------------------------------------------------------------------------ 13328# We found the first source code line. Bail out. 13329#------------------------------------------------------------------------------ 13330 if (($input_line =~ /$end_src1_header_regex/) or 13331 ($input_line =~ /$end_src2_header_regex/)) 13332 { 13333 gp_message ("debugXL", $subr_name, "header time is over - hit source line"); 13334 gp_message ("debugXL", $subr_name, "line_number = $line_number"); 13335 gp_message ("debugXL", $subr_name, "input_line = $input_line"); 13336 last; 13337 } 13338 else 13339#------------------------------------------------------------------------------ 13340# Store the header lines in the html structure. 13341#------------------------------------------------------------------------------ 13342 { 13343 $modified_line = "<i>" . $input_line . "</i>"; 13344 push (@modified_html, $modified_line); 13345 } 13346 } 13347#------------------------------------------------------------------------------ 13348# We know the source code starts at this index value: 13349#------------------------------------------------------------------------------ 13350 $start_all_source = scalar (@modified_html); 13351 gp_message ("debugXL", $subr_name, "source starts at start_all_source = $start_all_source"); 13352 13353#------------------------------------------------------------------------------ 13354# Scan the file to identify where the target source starts and ends. 13355#------------------------------------------------------------------------------ 13356 gp_message ("debugXL", $subr_name, "search for target function $routine"); 13357 $start_tracking = $FALSE; 13358 $found_target = $FALSE; 13359 for (my $line_number=0; $line_number <= $#file_contents; $line_number++) 13360 { 13361 $input_line = $file_contents[$line_number]; 13362 13363 gp_message ("debugXL", $subr_name, "[$line_number] $input_line"); 13364 13365 if ($input_line =~ /$function_regex/) 13366 { 13367 if (defined ($1) and defined ($2)) 13368 { 13369 $func_name_in_src_file = $2; 13370 my $msg = "found a function - name = $func_name_in_src_file"; 13371 gp_message ("debugXL", $subr_name, $msg); 13372 13373 if ($start_tracking) 13374 { 13375 $start_tracking = $FALSE; 13376 $end_target_source = $line_number - 1; 13377 my $msg = "end_target_source = $end_target_source"; 13378 gp_message ("debugXL", $subr_name, $msg); 13379 last; 13380 } 13381 13382 if ($func_name_in_src_file eq $routine) 13383 { 13384 $found_target = $TRUE; 13385 $start_tracking = $TRUE; 13386 $start_target_source = $line_number; 13387 13388 gp_message ("debugXL", $subr_name, "found target function $routine"); 13389 gp_message ("debugXL", $subr_name, "function_name = $2 routine = $routine"); 13390 gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); 13391 gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); 13392 } 13393 } 13394 else 13395 { 13396 my $msg = "parsing line $input_line"; 13397 gp_message ("assertion", $subr_name, $msg); 13398 } 13399 } 13400 } 13401 13402#------------------------------------------------------------------------------ 13403# This is not supposed to happen, but it is not a fatal error either. The 13404# hyperlinks related to this function will not work, so a warning is issued. 13405# A message is issued both in debug mode, and as a warning. 13406#------------------------------------------------------------------------------ 13407 if (not $found_target) 13408 { 13409 my $msg; 13410 gp_message ("debug", $subr_name, "target function $routine not found"); 13411 13412 $msg = "function $routine not found in $base - " . 13413 "links to source code involving this function will not work"; 13414 gp_message ("warning", $subr_name, $msg); 13415 13416 return ($found_target); 13417 } 13418 13419#------------------------------------------------------------------------------ 13420# Catch the line number of the last function. 13421#------------------------------------------------------------------------------ 13422 if ($start_tracking) 13423 { 13424 $end_target_source = $#file_contents; 13425 } 13426 gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); 13427 gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); 13428 gp_message ("debugXL", $subr_name, "end_target_source = $end_target_source"); 13429 13430#------------------------------------------------------------------------------ 13431# We now have the index range for the function of interest and will parse it. 13432# Since we already handled the first line with the function marker, we start 13433# with the line following. 13434#------------------------------------------------------------------------------ 13435 13436#------------------------------------------------------------------------------ 13437# Find the hot source lines and store them. 13438#------------------------------------------------------------------------------ 13439 gp_message ("debugXL", $subr_name, "determine the maximum metric values"); 13440 for (my $line_number=$start_target_source+1; $line_number <= $end_target_source; $line_number++) 13441 { 13442 $input_line = $file_contents[$line_number]; 13443 gp_message ("debugXL", $subr_name, " $line_number : check input_line = $input_line"); 13444 13445 if ( $input_line =~ /$hot_lines_regex/ ) 13446 { 13447 gp_message ("debugXL", $subr_name, " $line_number : found a hot line"); 13448#------------------------------------------------------------------------------ 13449# We found a hot line and the metric fields are stored in $2. We turn this 13450# string into an array and add it as a row to hot_source_lines. 13451#------------------------------------------------------------------------------ 13452 $hot_line = $1; 13453 $metric_values = $2; 13454 13455 gp_message ("debugXL", $subr_name, "hot_line = $hot_line"); 13456 gp_message ("debugXL", $subr_name, "metric_values = $metric_values"); 13457 13458 my @metrics = split (" ", $metric_values); 13459 push (@hot_source_lines, [@metrics]); 13460 } 13461 gp_message ("debugXL", $subr_name, " $line_number : completed check for hot line"); 13462 } 13463 13464#------------------------------------------------------------------------------ 13465# Transpose the array with the hot lines. This means each row has all the 13466# values for a metrict and it makes it easier to determine the maximum values. 13467#------------------------------------------------------------------------------ 13468 for my $row (keys @hot_source_lines) 13469 { 13470 my $msg = "row[" . $row . "] = "; 13471 for my $col (keys @{$hot_source_lines[$row]}) 13472 { 13473 $msg .= "$hot_source_lines[$row][$col] "; 13474 $transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col]; 13475 } 13476 } 13477 13478#------------------------------------------------------------------------------ 13479# Print the maximum metric values found. Each row contains the data for a 13480# different metric. 13481#------------------------------------------------------------------------------ 13482 for my $row (keys @transposed_hot_lines) 13483 { 13484 my $msg = "row[" . $row . "] = "; 13485 for my $col (keys @{$transposed_hot_lines[$row]}) 13486 { 13487 $msg .= "$transposed_hot_lines[$row][$col] "; 13488 } 13489 gp_message ("debugXL", $subr_name, "hot lines = $msg"); 13490 } 13491 13492#------------------------------------------------------------------------------ 13493# Determine the maximum value for each metric. 13494#------------------------------------------------------------------------------ 13495 for my $row (keys @transposed_hot_lines) 13496 { 13497 my $max_val = 0; 13498 for my $col (keys @{$transposed_hot_lines[$row]}) 13499 { 13500 $max_val = max ($transposed_hot_lines[$row][$col], $max_val); 13501 } 13502#------------------------------------------------------------------------------ 13503# Convert to a floating point number. 13504#------------------------------------------------------------------------------ 13505 if ($max_val =~ /$integer_only_regex/) 13506 { 13507 $max_val = sprintf ("%f", $max_val); 13508 } 13509 push (@max_metric_values, $max_val); 13510 } 13511 13512 for my $metric (keys @max_metric_values) 13513 { 13514 my $msg = "$input_filename max_metric_values[$metric] = " . 13515 $max_metric_values[$metric]; 13516 gp_message ("debugXL", $subr_name, $msg); 13517 } 13518 13519#------------------------------------------------------------------------------ 13520# Process those functions that are not the current target. 13521#------------------------------------------------------------------------------ 13522 $modified_html_ref = process_non_target_source ($start_all_source, 13523 $start_target_source-1, 13524 $src_times_regex, 13525 $function_regex, 13526 $number_of_metrics, 13527 \@file_contents, 13528 \@modified_html); 13529 @modified_html = @{ $modified_html_ref }; 13530 13531#------------------------------------------------------------------------------ 13532# This is the core part to process the information for the target function. 13533#------------------------------------------------------------------------------ 13534 gp_message ("debugXL", $subr_name, "parse and process the target source"); 13535 $modified_html_ref = process_target_source ($start_target_source, 13536 $end_target_source, 13537 $routine, 13538 \@max_metric_values, 13539 $src_times_regex, 13540 $function2_regex, 13541 $number_of_metrics, 13542 \@file_contents, 13543 \@modified_html); 13544 @modified_html = @{ $modified_html_ref }; 13545 13546 if ($end_target_source < $#file_contents) 13547 { 13548 $modified_html_ref = process_non_target_source ($end_target_source+1, 13549 $#file_contents, 13550 $src_times_regex, 13551 $function_regex, 13552 $number_of_metrics, 13553 \@file_contents, 13554 \@modified_html); 13555 @modified_html = @{ $modified_html_ref }; 13556 } 13557 13558 gp_message ("debug", $subr_name, "completed reading source"); 13559 13560#------------------------------------------------------------------------------ 13561# Add an extra line with diagnostics. 13562# 13563# TBD: The same is done in generate_dis_html but should be done only once. 13564#------------------------------------------------------------------------------ 13565 if ($hp_value > 0) 13566 { 13567 my $rounded_percentage = sprintf ("%.1f", $hp_value); 13568 $threshold_line = "<i>The setting for the highlight percentage (-hp) option: $rounded_percentage (%)</i>"; 13569 } 13570 else 13571 { 13572 $threshold_line = "<i>The highlight percentage (-hp) feature is not enabled</i>"; 13573 } 13574 13575 $html_home = ${ generate_home_link ("left") }; 13576 $html_end = ${ terminate_html_document () }; 13577 13578 push (@modified_html, "</pre>"); 13579 push (@modified_html, "<br>"); 13580 push (@modified_html, $threshold_line); 13581 push (@modified_html, $html_home); 13582 push (@modified_html, "<br>"); 13583 push (@modified_html, $g_html_credits_line); 13584 push (@modified_html, $html_end); 13585 13586 for my $i (0 .. $#modified_html) 13587 { 13588 gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]"); 13589 } 13590 13591#------------------------------------------------------------------------------ 13592# Write the generated HTML text to file. 13593#------------------------------------------------------------------------------ 13594 for my $i (0 .. $#modified_html) 13595 { 13596 print NEW_HTML "$modified_html[$i]" . "\n"; 13597 } 13598 close (NEW_HTML); 13599 close (SRC_LISTING); 13600 13601 return ($found_target); 13602 13603} #-- End of subroutine process_source 13604 13605#------------------------------------------------------------------------------ 13606# Process the source lines for the target function. 13607#------------------------------------------------------------------------------ 13608sub process_target_source 13609{ 13610 my $subr_name = get_my_name (); 13611 13612 my ($start_scan, $end_scan, $target_function, $max_metric_values_ref, 13613 $src_times_regex, $function2_regex, $number_of_metrics, 13614 $file_contents_ref, $modified_html_ref) = @_; 13615 13616 my @file_contents = @{ $file_contents_ref }; 13617 my @modified_html = @{ $modified_html_ref }; 13618 my @max_metric_values = @{ $max_metric_values_ref }; 13619 13620 my @components = (); 13621 13622 my $colour_coded_line; 13623 my $colour_coded_line_ref; 13624 my $hot_line; 13625 my $input_line; 13626 my $line_id; 13627 my $modified_line; 13628 my $metric_values; 13629 my $src_code_line; 13630 my $src_line_no; 13631 13632 gp_message ("debug", $subr_name, "parse and process the core loop"); 13633 13634 for (my $line_number=$start_scan; $line_number <= $end_scan; $line_number++) 13635 { 13636 $input_line = $file_contents[$line_number]; 13637 13638#------------------------------------------------------------------------------ 13639# We need to replace the "<" symbol in the code by "<". 13640#------------------------------------------------------------------------------ 13641 $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 13642 13643 $line_id = extract_source_line_number ($src_times_regex, 13644 $function2_regex, 13645 $number_of_metrics, 13646 $input_line); 13647 13648 gp_message ("debug", $subr_name, "line_number = $line_number : input_line = $input_line line_id = $line_id"); 13649 13650 if ($input_line =~ /$function2_regex/) 13651#------------------------------------------------------------------------------ 13652# Found the function marker. 13653#------------------------------------------------------------------------------ 13654 { 13655 if (defined ($1) and defined ($2)) 13656 { 13657 my $func_name_in_file = $2; 13658 my $spaces = $1; 13659 my $boldface = $TRUE; 13660 gp_message ("debug", $subr_name, "function_name = $2"); 13661 my $function_line = "<Function: " . $func_name_in_file . ">"; 13662 my $color_function_name = color_string ( 13663 $function_line, 13664 $boldface, 13665 $g_html_color_scheme{"target_function_name"}); 13666 my $ftag; 13667 if (exists ($g_function_tag_id{$target_function})) 13668 { 13669 $ftag = $g_function_tag_id{$target_function}; 13670 gp_message ("debug", $subr_name, "target_function = $target_function ftag = $ftag"); 13671 } 13672 else 13673 { 13674 my $msg = "no ftag found for $target_function"; 13675 gp_message ("assertion", $subr_name, $msg); 13676 } 13677 $modified_line = "<a id=\"" . $ftag . "\"></a>"; 13678 $modified_line .= $spaces . "<i>" . $color_function_name . "</i>"; 13679 } 13680 } 13681 elsif ($input_line =~ /$src_times_regex/) 13682#------------------------------------------------------------------------------ 13683# This is a line with metric values. 13684#------------------------------------------------------------------------------ 13685 { 13686 gp_message ("debug", $subr_name, "input line has metrics"); 13687 13688 $hot_line = $1; 13689 $metric_values = $2; 13690 $src_line_no = $3; 13691 $src_code_line = $4; 13692 13693 gp_message ("debug", $subr_name, "hot_line = $hot_line"); 13694 gp_message ("debug", $subr_name, "metric_values = $metric_values"); 13695 gp_message ("debug", $subr_name, "src_line_no = $src_line_no"); 13696 gp_message ("debug", $subr_name, "src_code_line = $src_code_line"); 13697 13698 if ($hot_line eq "##") 13699#------------------------------------------------------------------------------ 13700# Highlight the most expensive line. 13701#------------------------------------------------------------------------------ 13702 { 13703 @components = split (" ", $input_line, 1+$number_of_metrics+2); 13704 $modified_line = set_background_color_string ( 13705 $input_line, 13706 $g_html_color_scheme{"background_color_hot"}); 13707 } 13708 else 13709 { 13710#------------------------------------------------------------------------------ 13711# Highlight those lines close enough to the most expensive line. 13712#------------------------------------------------------------------------------ 13713 @components = split (" ", $input_line, $number_of_metrics + 2); 13714 for my $i (0 .. $number_of_metrics-1) 13715 { 13716 gp_message ("debugXL", $subr_name, "$line_number : time check components[$i] = $components[$i]"); 13717 } 13718 13719 $colour_coded_line_ref = check_metric_values ($metric_values, \@max_metric_values); 13720 13721 $colour_coded_line = $ {$colour_coded_line_ref}; 13722 if ($colour_coded_line) 13723 { 13724 gp_message ("debugXL", $subr_name, "$line_number : change background colour modified_line = $modified_line"); 13725 $modified_line = set_background_color_string ($input_line, $g_html_color_scheme{"background_color_lukewarm"}); 13726 } 13727 else 13728 { 13729 $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; 13730 $modified_line .= "$input_line"; 13731 } 13732 } 13733 } 13734 else 13735#------------------------------------------------------------------------------ 13736# This is a regular line that is not modified. 13737#------------------------------------------------------------------------------ 13738 { 13739#------------------------------------------------------------------------------ 13740# Add an id. 13741#------------------------------------------------------------------------------ 13742 gp_message ("debug", $subr_name, "$line_number : input line is a regular line"); 13743 $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; 13744 $modified_line .= "$input_line"; 13745 } 13746 gp_message ("debug", $subr_name, "$line_number : mod = $modified_line"); 13747 push (@modified_html, $modified_line); 13748 } 13749 13750 return (\@modified_html); 13751 13752} #-- End of subroutine process_target_source 13753 13754#------------------------------------------------------------------------------ 13755# Process the options. Set associated variables and check the options for 13756# correctness. For example, detect if conflicting options have been set. 13757#------------------------------------------------------------------------------ 13758sub process_user_options 13759{ 13760 my $subr_name = get_my_name (); 13761 13762 my ($exp_dir_list_ref) = @_; 13763 13764 my @exp_dir_list = @{ $exp_dir_list_ref }; 13765 13766 my %ignored_metrics = (); 13767 13768 my $error_code; 13769 my $message; 13770 13771 my $outputdir; 13772 13773 my $target_cmd; 13774 my $rm_output_msg; 13775 my $mkdir_output_msg; 13776 my $time_percentage_multiplier; 13777 my $process_all_functions; 13778 13779 my $option_errors = 0; 13780 13781#------------------------------------------------------------------------------ 13782# The -o and -O options are mutually exclusive. 13783#------------------------------------------------------------------------------ 13784 my $define_new_output_dir = $g_user_settings{"output"}{"defined"}; 13785 my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"}; 13786 my $dir_o_option = $g_user_settings{"output"}{"current_value"}; 13787 my $dir_O_option = $g_user_settings{"overwrite"}{"current_value"}; 13788 13789 if ($define_new_output_dir and $overwrite_output_dir) 13790 { 13791 my $msg; 13792 13793 $msg = "the -o/--output and -O/--overwrite options are both set, " . 13794 "but are mutually exclusive"; 13795 push (@g_user_input_errors, $msg); 13796 13797 $msg = "(setting for -o = $dir_o_option, " . 13798 "setting for -O = $dir_O_option)"; 13799 push (@g_user_input_errors, $msg); 13800 13801 $option_errors++; 13802 } 13803 13804#------------------------------------------------------------------------------ 13805# Define the quiet mode. While this is an on/off keyword in the input, we 13806# use a boolean in the remainder, because it reads easier. 13807#------------------------------------------------------------------------------ 13808 my $quiet_value = $g_user_settings{"quiet"}{"current_value"}; 13809 $g_quiet = ($quiet_value eq "on") ? $TRUE : $FALSE; 13810 13811#------------------------------------------------------------------------------ 13812# In quiet mode, all verbose, warnings and debug messages are suppressed. 13813#------------------------------------------------------------------------------ 13814 if ($g_quiet) 13815 { 13816 $g_user_settings{"verbose"}{"current_value"} = "off"; 13817 $g_user_settings{"warnings"}{"current_value"} = "off"; 13818 $g_user_settings{"debug"}{"current_value"} = "off"; 13819 $g_verbose = $FALSE; 13820 $g_warnings = $FALSE; 13821 my $debug_off = "off"; 13822 my $ignore_value = set_debug_size (\$debug_off); 13823 } 13824 else 13825 { 13826#------------------------------------------------------------------------------ 13827# Get the verbose mode. 13828#------------------------------------------------------------------------------ 13829 my $verbose_value = $g_user_settings{"verbose"}{"current_value"}; 13830 $g_verbose = ($verbose_value eq "on") ? $TRUE : $FALSE; 13831#------------------------------------------------------------------------------ 13832# Get the warning mode. 13833#------------------------------------------------------------------------------ 13834 my $warning_value = $g_user_settings{"warnings"}{"current_value"}; 13835 $g_warnings = ($warning_value eq "on") ? $TRUE : $FALSE; 13836 } 13837 13838#------------------------------------------------------------------------------ 13839# The value for HP should be in the interval (0,100]. We already enforced 13840# the number to be positive, but the limits have not been checked yet. 13841#------------------------------------------------------------------------------ 13842 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; 13843 13844 if (($hp_value < 0) or ($hp_value > 100)) 13845 { 13846 my $msg = "the value for the highlight percentage is set to $hp_value, "; 13847 $msg .= "but must be in the range [0, 100]"; 13848 push (@g_user_input_errors, $msg); 13849 13850 $option_errors++; 13851 } 13852 13853#------------------------------------------------------------------------------ 13854# The value for TP should be in the interval (0,100]. We already enforced 13855# the number to be positive, but the limits have not been checked yet. 13856#------------------------------------------------------------------------------ 13857 my $tp_value = $g_user_settings{"threshold_percentage"}{"current_value"}; 13858 13859 if (($tp_value < 0) or ($tp_value > 100)) 13860 { 13861 my $msg = "the value for the total percentage is set to $tp_value, " . 13862 "but must be in the range (0, 100]"; 13863 push (@g_user_input_errors, $message); 13864 13865 $option_errors++; 13866 } 13867 else 13868 { 13869 $time_percentage_multiplier = $tp_value/100.0; 13870 13871# Ruud if (($TIME_PERCENTAGE_MULTIPLIER*100.) >= 100.) 13872 13873 if ($tp_value == 100) 13874 { 13875 $process_all_functions = $TRUE; # ensure that all routines are handled 13876 } 13877 else 13878 { 13879 $process_all_functions = $FALSE; 13880 } 13881 13882 my $txt; 13883 $txt = "value of time_percentage_multiplier = " . 13884 $time_percentage_multiplier; 13885 gp_message ("debugM", $subr_name, $txt); 13886 $txt = "value of process_all_functions = " . 13887 ($process_all_functions ? "TRUE" : "FALSE"); 13888 gp_message ("debugM", $subr_name, $txt); 13889 } 13890 13891#------------------------------------------------------------------------------ 13892# If imetrics has been set, split the list into the individual metrics that 13893# need to be excluded. The associated hash called $ignore_metrics has the 13894# to be excluded metrics as an index. The value of $TRUE assigned does not 13895# really matter. 13896#------------------------------------------------------------------------------ 13897 my @candidate_ignored_metrics; 13898 13899 if ($g_user_settings{"ignore_metrics"}{"defined"}) 13900 { 13901 @candidate_ignored_metrics = 13902 split (":", $g_user_settings{"ignore_metrics"}{"current_value"}); 13903 } 13904 for my $metric (@candidate_ignored_metrics) 13905 { 13906# TBD: bug? $ignored_metrics{$metric} = $FALSE; 13907 $ignored_metrics{$metric} = $TRUE; 13908 } 13909 for my $metric (keys %ignored_metrics) 13910 { 13911 my $txt = "ignored_metrics{$metric} = $ignored_metrics{$metric}"; 13912 gp_message ("debugM", $subr_name, $txt); 13913 } 13914 13915#------------------------------------------------------------------------------ 13916# Check if the experiment directories exist. 13917#------------------------------------------------------------------------------ 13918 for my $i (0 .. $#exp_dir_list) 13919 { 13920 if (-d $exp_dir_list[$i]) 13921 { 13922 my $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]); 13923 $exp_dir_list[$i] = $abs_path_dir; 13924 my $txt = "directory $exp_dir_list[$i] exists"; 13925 gp_message ("debugM", $subr_name, $txt); 13926 } 13927 else 13928 { 13929 my $msg = "directory $exp_dir_list[$i] does not exist"; 13930 13931 push (@g_user_input_errors, $msg); 13932 $option_errors++; 13933 } 13934 } 13935 13936 return ($option_errors, \%ignored_metrics, $outputdir, 13937 $time_percentage_multiplier, $process_all_functions, 13938 \@exp_dir_list); 13939 13940} #-- End of subroutine process_user_options 13941 13942#------------------------------------------------------------------------------ 13943# This is a hopefully temporary routine to disable/ignore selected user 13944# settings. As the functionality expands, this list will get shorter. 13945#------------------------------------------------------------------------------ 13946sub reset_selected_settings 13947{ 13948 my $subr_name = get_my_name (); 13949 13950 $g_locale_settings{"decimal_separator"} = "\\."; 13951 $g_locale_settings{"convert_to_dot"} = $FALSE; 13952 $g_user_settings{func_limit}{current_value} = 1000000; 13953 13954 gp_message ("debug", $subr_name, "reset selected settings"); 13955 13956 return (0); 13957 13958} #-- End of subroutine reset_selected_settings 13959 13960#------------------------------------------------------------------------------ 13961# There may be various different visibility characters in a metric definition. 13962# For example: e+%CPI. 13963# 13964# Internally we use a normalized definition that only uses the dot (e.g. 13965# e.CPI) as an index into the description structure. 13966# 13967# Here we reduce the incoming metric definition to the normalized form, look 13968# up the text, and return a pointer to it. 13969#------------------------------------------------------------------------------ 13970sub retrieve_metric_description 13971{ 13972 my $subr_name = get_my_name (); 13973 13974 my ($metric_name_ref, $metric_description_ref) = @_; 13975 13976 my $metric_name = ${ $metric_name_ref }; 13977 my %metric_description = %{ $metric_description_ref }; 13978 13979 my $description; 13980 my $normalized_metric; 13981 13982 $metric_name =~ /([ei])([\.\+%]+)(.*)/; 13983 13984 if (defined ($1) and defined ($3)) 13985 { 13986 $normalized_metric = $1 . "." . $3; 13987 } 13988 else 13989 { 13990 my $msg = "metric $metric_name has an unknown format"; 13991 gp_message ("assertion", $subr_name, $msg); 13992 } 13993 13994 if (defined ($metric_description{$normalized_metric})) 13995 { 13996 $description = $metric_description{$normalized_metric}; 13997 } 13998 else 13999 { 14000 my $msg = "description for normalized metric $normalized_metric not found"; 14001 gp_message ("assertion", $subr_name, $msg); 14002 } 14003 14004 return (\$description); 14005 14006} #-- End of subroutine retrieve_metric_description 14007 14008#------------------------------------------------------------------------------ 14009# TBD. 14010#------------------------------------------------------------------------------ 14011sub rnumerically 14012{ 14013 my ($f1,$f2); 14014 if ($a =~ /^([^\d]*)(\d+)/) 14015 { 14016 $f1 = int ($2); 14017 if ($b=~ /^([^\d]*)(\d+)/) 14018 { 14019 $f2 = int ($2); 14020 $f1 == $f2 ? 0 : ($f1 > $f2 ? -1 : +1); 14021 } 14022 } 14023 else 14024 { 14025 return ($b <=> $a); 14026 } 14027} #-- End of subroutine rnumerically 14028 14029#------------------------------------------------------------------------------ 14030# TBD: Remove - not used any longer. 14031# Set the architecture and associated regular expressions. 14032#------------------------------------------------------------------------------ 14033sub set_arch_and_regexes 14034{ 14035 my $subr_name = get_my_name (); 14036 14037 my ($arch_uname) = @_; 14038 14039 my $architecture_supported; 14040 14041 gp_message ("debug", $subr_name, "arch_uname = $arch_uname"); 14042 14043 if ($arch_uname eq "x86_64") 14044 { 14045 #x86/x64 hardware uses jump 14046 $architecture_supported = $TRUE; 14047# $arch='x64'; 14048# $regex=':\s+(j).*0x[0-9a-f]+'; 14049# $subexp='(\[\s*)(0x[0-9a-f]+)'; 14050# $linksubexp='(\[\s*)(0x[0-9a-f]+)'; 14051 gp_message ("debug", $subr_name, "detected $arch_uname hardware"); 14052 14053 $architecture_supported = $TRUE; 14054 $g_arch_specific_settings{"arch_supported"} = $TRUE; 14055 $g_arch_specific_settings{"arch"} = 'x64'; 14056 $g_arch_specific_settings{"regex"} = ':\s+(j).*0x[0-9a-f]+'; 14057 $g_arch_specific_settings{"subexp"} = '(\[\s*)(0x[0-9a-f]+)'; 14058 $g_arch_specific_settings{"linksubexp"} = '(\[\s*)(0x[0-9a-f]+)'; 14059 } 14060#------------------------------------------------------------------------------- 14061# TBD: Remove the elsif block 14062#------------------------------------------------------------------------------- 14063 elsif ($arch_uname=~m/sparc/s) 14064 { 14065 #sparc hardware uses branch 14066 $architecture_supported = $FALSE; 14067# $arch='sparc'; 14068# $regex=':\s+(c|b|fb).*0x[0-9a-f]+\s*$'; 14069# $subexp='(\s*)(0x[0-9a-f]+)\s*$'; 14070# $linksubexp='(\s*)(0x[0-9a-f]+\s*$)'; 14071# gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch - this is no longer supported"); 14072 $architecture_supported = $FALSE; 14073 $g_arch_specific_settings{arch_supported} = $FALSE; 14074 $g_arch_specific_settings{arch} = 'sparc'; 14075 $g_arch_specific_settings{regex} = ':\s+(c|b|fb).*0x[0-9a-f]+\s*$'; 14076 $g_arch_specific_settings{subexp} = '(\s*)(0x[0-9a-f]+)\s*$'; 14077 $g_arch_specific_settings{linksubexp} = '(\s*)(0x[0-9a-f]+\s*$)'; 14078 } 14079 else 14080 { 14081 $architecture_supported = $FALSE; 14082 gp_message ("debug", $subr_name, "detected $arch_uname hardware - this not supported; limited functionality"); 14083 } 14084 14085 return ($architecture_supported); 14086 14087} #-- End of subroutine set_arch_and_regexes 14088 14089#------------------------------------------------------------------------------ 14090# Set the background color of the input string. 14091# 14092# For supported colors, see: 14093# https://www.w3schools.com/colors/colors_names.asp 14094#------------------------------------------------------------------------------ 14095sub set_background_color_string 14096{ 14097 my $subr_name = get_my_name (); 14098 14099 my ($input_string, $color) = @_; 14100 14101 my $background_color_string; 14102 my $msg; 14103 14104 $msg = "color = $color input_string = $input_string"; 14105 gp_message ("debugXL", $subr_name, $msg); 14106 14107 $background_color_string = "<span style='background-color: " . $color . 14108 "'>" . $input_string . "</span>"; 14109 14110 $msg = "color = $color background_color_string = " . 14111 $background_color_string; 14112 gp_message ("debugXL", $subr_name, $msg); 14113 14114 return ($background_color_string); 14115 14116} #-- End of subroutine set_background_color_string 14117 14118#------------------------------------------------------------------------------ 14119# Set the g_debug_size structure for a given value for "size". Also set the 14120# value in $g_user_settings{"debug"}{"current_value"} 14121#------------------------------------------------------------------------------ 14122sub set_debug_size 14123{ 14124 my $subr_name = get_my_name (); 14125 14126 my ($debug_value_ref) = @_; 14127 14128 my $debug_value = lc (${ $debug_value_ref }); 14129 14130#------------------------------------------------------------------------------ 14131# Regardless of the value, the debug settings are defined here. 14132#------------------------------------------------------------------------------ 14133 $g_user_settings{"debug"}{"defined"} = $TRUE; 14134 14135#------------------------------------------------------------------------------ 14136# By default, set the value to "on", but correct below if needed. 14137#------------------------------------------------------------------------------ 14138 $g_user_settings{"debug"}{"current_value"} = "on"; 14139 14140 if (($debug_value eq "on") or ($debug_value eq "s")) 14141 { 14142 $g_debug_size{"on"} = $TRUE; 14143 $g_debug_size{"s"} = $TRUE; 14144 } 14145 elsif ($debug_value eq "m") 14146 { 14147 $g_debug_size{"on"} = $TRUE; 14148 $g_debug_size{"s"} = $TRUE; 14149 $g_debug_size{"m"} = $TRUE; 14150 } 14151 elsif ($debug_value eq "l") 14152 { 14153 $g_debug_size{"on"} = $TRUE; 14154 $g_debug_size{"s"} = $TRUE; 14155 $g_debug_size{"m"} = $TRUE; 14156 $g_debug_size{"l"} = $TRUE; 14157 } 14158 elsif ($debug_value eq "xl") 14159 { 14160 $g_debug_size{"on"} = $TRUE; 14161 $g_debug_size{"s"} = $TRUE; 14162 $g_debug_size{"m"} = $TRUE; 14163 $g_debug_size{"l"} = $TRUE; 14164 $g_debug_size{"xl"} = $TRUE; 14165 } 14166 else 14167#------------------------------------------------------------------------------ 14168# Any other value is considered to disable debugging. 14169#------------------------------------------------------------------------------ 14170 { 14171 $g_user_settings{"debug"}{"current_value"} = "off"; 14172 $g_debug_size{"on"} = $FALSE; 14173 $g_debug_size{"s"} = $FALSE; 14174 $g_debug_size{"m"} = $FALSE; 14175 $g_debug_size{"l"} = $FALSE; 14176 $g_debug_size{"xl"} = $FALSE; 14177 } 14178 14179#------------------------------------------------------------------------------ 14180# Activate in case of an emergency :-) 14181#------------------------------------------------------------------------------ 14182## if ($g_debug_size{$debug_value}) 14183## { 14184## for my $i (keys %g_debug_size) 14185## { 14186## print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n"; 14187## } 14188## } 14189 14190 return (0); 14191 14192} #-- End of subroutine set_debug_size 14193 14194#------------------------------------------------------------------------------ 14195# This subroutine defines the default metrics. 14196#------------------------------------------------------------------------------ 14197sub set_default_metrics 14198{ 14199 my $subr_name = get_my_name (); 14200 14201 my ($outfile1, $ignored_metrics_ref) = @_; 14202 14203 my %ignored_metrics = %{ $ignored_metrics_ref }; 14204 14205 my %metric_description = (); 14206 my %metric_found = (); 14207 14208 my $detail_metrics; 14209 my $detail_metrics_system; 14210 14211 my $call_metrics = ""; 14212 my $summary_metrics = ""; 14213 14214 open (METRICS, "<", $outfile1) 14215 or die ("Unable to open metrics file $outfile1 for reading - '$!'"); 14216 gp_message ("debug", $subr_name, "opened $outfile1 for reading"); 14217 14218 while (<METRICS>) 14219 { 14220 my $metric_line = $_; 14221 chomp ($metric_line); 14222 14223 gp_message ("debug", $subr_name,"the value of metric_line = $metric_line"); 14224 14225#------------------------------------------------------------------------------ 14226# Decode the metric part of the input line. If a valid line, return the 14227# metric components. Otherwise return "skipped" in the metric_spec field. 14228#------------------------------------------------------------------------------ 14229 my ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description) = extract_metric_specifics ($metric_line); 14230 14231 gp_message ("debug", $subr_name, "metric_spec = $metric_spec"); 14232 gp_message ("debug", $subr_name, "metric_flavor = $metric_flavor"); 14233 14234 if ($metric_spec eq "skipped") 14235#------------------------------------------------------------------------------ 14236# Not a valid input line. 14237#------------------------------------------------------------------------------ 14238 { 14239 gp_message ("debug", $subr_name, "skipped line: $metric_line"); 14240 } 14241 else 14242 { 14243#------------------------------------------------------------------------------ 14244# A valid metric field has been found. 14245#------------------------------------------------------------------------------ 14246 gp_message ("debug", $subr_name, "metric_name = $metric_name"); 14247 gp_message ("debug", $subr_name, "metric_description = $metric_description"); 14248 14249# if (exists ($IMETRICS{$m})){ 14250 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{$metric_name})) 14251 { 14252 gp_message ("debug", $subr_name, "user requested to ignore metric $metric_name"); 14253 next; 14254 } 14255 14256#------------------------------------------------------------------------------ 14257# Only the exclusive metric is selected. 14258#------------------------------------------------------------------------------ 14259 if ($metric_flavor eq "e") 14260 { 14261 $metric_found{$metric_spec} = $TRUE; 14262 $metric_description{$metric_spec} = $metric_description; 14263 14264# TBD: remove the -AO: 14265 gp_message ("debug", $subr_name,"-AO metric_description{$metric_spec} = $metric_description{$metric_spec}"); 14266 14267 $summary_metrics .= $metric_spec.":"; 14268 $call_metrics .= "a.".$metric_name.":"; 14269 } 14270 } 14271 } 14272 close (METRICS); 14273 14274 chop ($call_metrics); 14275 chop ($summary_metrics); 14276 14277 $detail_metrics = $summary_metrics; 14278 $detail_metrics_system = $summary_metrics; 14279 14280 return (\%metric_description, \%metric_found, 14281 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics); 14282 14283} #-- End of subroutine set_default_metrics 14284 14285#------------------------------------------------------------------------------ 14286# Set various system specific variables. These depend upon both the processor 14287# architecture and OS. The values are stored in global structure 14288# g_arch_specific_settings. 14289#------------------------------------------------------------------------------ 14290sub set_system_specific_variables 14291{ 14292 my $subr_name = get_my_name (); 14293 14294 my ($arch_uname, $arch_uname_s) = @_; 14295 14296 my $elf_arch; 14297 my $read_elf_cmd; 14298 my $elf_support; 14299 my $architecture_supported; 14300 my $arch; 14301 my $regex; 14302 my $subexp; 14303 my $linksubexp; 14304 14305 if ($arch_uname eq "x86_64") 14306 { 14307#------------------------------------------------------------------------------ 14308# x86/x64 hardware uses jump 14309#------------------------------------------------------------------------------ 14310 $architecture_supported = $TRUE; 14311 $arch = 'x64'; 14312 $regex =':\s+(j).*0x[0-9a-f]+'; 14313 $subexp ='(\[\s*)(0x[0-9a-f]+)'; 14314 $linksubexp ='(\[\s*)(0x[0-9a-f]+)'; 14315 14316# gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch"); 14317 14318 $g_arch_specific_settings{"arch_supported"} = $TRUE; 14319 $g_arch_specific_settings{"arch"} = 'x64'; 14320#------------------------------------------------------------------------------ 14321# Define the regular expressions to parse branch instructions. 14322#------------------------------------------------------------------------------ 14323 14324#------------------------------------------------------------------------------ 14325# TBD: Need much more than these 14326#------------------------------------------------------------------------------ 14327 $g_arch_specific_settings{"regex"} = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; 14328 $g_arch_specific_settings{"subexp"} = '(0x[0-9a-f]+)'; 14329 $g_arch_specific_settings{"linksubexp"} = '(\s*)(0x[0-9a-f]+)'; 14330 } 14331 else 14332 { 14333 $architecture_supported = $FALSE; 14334 $g_arch_specific_settings{"arch_supported"} = $FALSE; 14335 } 14336 14337#------------------------------------------------------------------------------ 14338# TBD Ruud: need to handle this better 14339#------------------------------------------------------------------------------ 14340 if ($arch_uname_s eq "Linux") 14341 { 14342 $elf_arch = $arch_uname_s; 14343 $read_elf_cmd = $g_mapped_cmds{"readelf"}; 14344 14345 if ($read_elf_cmd eq "road_to_nowhere") 14346 { 14347 $elf_support = $FALSE; 14348 } 14349 else 14350 { 14351 $elf_support = $TRUE; 14352 } 14353 gp_message ("debugXL", $subr_name, "elf_support = $elf_support read_elf_cmd = $read_elf_cmd elf_arch = $elf_arch"); 14354 } 14355 else 14356 { 14357 gp_message ("abort", $subr_name, "the $arch_uname_s operating system is not supported"); 14358 } 14359 14360 return ($architecture_supported, $elf_arch, $elf_support); 14361 14362} #-- End of subroutine set_system_specific_variables 14363 14364#------------------------------------------------------------------------------ 14365# TBD 14366#------------------------------------------------------------------------------ 14367sub set_title 14368{ 14369 my $subr_name = get_my_name (); 14370 14371 my ($function_info_ref, $func, $from_where) = @_ ; 14372 14373 my $msg; 14374 my @function_info = @{$function_info_ref}; 14375 my $filename = $func ; 14376 14377 my $base; 14378 my $first_line; 14379 my $src_file; 14380 my $RI; 14381 my $the_title; 14382 my $routine = "?"; 14383 my $DIS; 14384 my $SRC; 14385 14386 chomp ($filename); 14387 14388 $base = get_basename ($filename); 14389 14390 gp_message ("debug", $subr_name, "from_where = $from_where"); 14391 gp_message ("debug", $subr_name, "base = $base filename = $filename"); 14392 14393 if ($from_where eq "process source") 14394 { 14395 if ($base =~ /^file\.(\d+)\.src\.txt$/) 14396 { 14397 if (defined ($1)) 14398 { 14399 $RI = $1; 14400 } 14401 else 14402 { 14403 $msg = "unexpected error encountered parsing $filename"; 14404 gp_message ("assertion", $subr_name, $msg); 14405 } 14406 } 14407 $the_title = "Source"; 14408 } 14409 elsif ($from_where eq "disassembly") 14410 { 14411 if ($base =~ /^file\.(\d+)\.dis$/) 14412 { 14413 if (defined ($1)) 14414 { 14415 $RI = $1; 14416 } 14417 else 14418 { 14419 $msg = "unexpected error encountered parsing $filename"; 14420 gp_message ("assertion", $subr_name, $msg); 14421 } 14422 } 14423 $the_title = "Disassembly"; 14424 } 14425 else 14426 { 14427 $msg = "called from unknown routine - $from_where"; 14428 gp_message ("assertion", $subr_name, $msg); 14429 } 14430 14431 if (defined ($function_info[$RI]{"routine"})) 14432 { 14433 $routine = $function_info[$RI]{"routine"}; 14434 } 14435 14436 if ($from_where eq "process source") 14437 { 14438 my $is_empty = is_file_empty ($filename); 14439 14440 if ($is_empty) 14441 { 14442 $src_file = ""; 14443 } 14444 else 14445 { 14446 open ($SRC, "<", $filename) 14447 or die ("$subr_name - unable to open source file $filename for reading:'$!'"); 14448 gp_message ("debug", $subr_name, "opened file $filename for reading"); 14449 14450 $first_line = <$SRC>; 14451 chomp ($first_line); 14452 14453 close ($SRC); 14454 14455 gp_message ("debug", $subr_name, "first_line = $first_line"); 14456 14457 if ($first_line =~ /^Source\s+file:\s+([^\s]+)/) 14458 { 14459 $src_file = $1 14460 } 14461 else 14462 { 14463 $src_file = ""; 14464 } 14465 } 14466 } 14467 elsif ($from_where eq "disassembly") 14468 { 14469 open ($DIS, "<", $filename) 14470 or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'"); 14471 gp_message ("debug", $subr_name, "opened file $filename for reading"); 14472 14473 $first_line = <$DIS>; 14474 close ($DIS); 14475 14476 if ($first_line =~ /^Source\s+file:\s+([^\s]+)/) 14477 { 14478 $src_file = "$1" 14479 } 14480 else 14481 { 14482 $src_file = ""; 14483 } 14484 } 14485 14486 if (length ($routine)) 14487 { 14488 $the_title .= " $routine"; 14489 } 14490 14491 if (length ($src_file)) 14492 { 14493 if ($src_file ne "(unknown)") 14494 { 14495 $the_title .= " ($src_file)"; 14496 } 14497 else 14498 { 14499 $the_title .= " $src_file"; 14500 } 14501 } 14502 14503 return ($the_title); 14504 14505} #-- End of subroutine set_title 14506 14507#------------------------------------------------------------------------------ 14508# Handles where the output should go. If needed, a directory is # created 14509# where the results will go. 14510#------------------------------------------------------------------------------ 14511sub set_up_output_directory 14512{ 14513 my $subr_name = get_my_name (); 14514 14515 my $error_code; 14516 my $message; 14517 my $mkdir_output_msg; 14518 my $option_errors; 14519 my $outputdir = "does_not_exist_yet"; 14520 my $rm_output_msg; 14521 my $target_cmd; 14522 14523 my $define_new_output_dir = $g_user_settings{"output"}{"defined"}; 14524 my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"}; 14525 14526 $option_errors = 0; 14527 14528 if ((not $define_new_output_dir) and (not $overwrite_output_dir)) 14529#------------------------------------------------------------------------------ 14530# If neither -o or -O are set, find the next number to be used in the name for 14531# the default output directory. 14532#------------------------------------------------------------------------------ 14533 { 14534 my $dir_id = 1; 14535 while (-d "display.".$dir_id.".html") 14536 { $dir_id++; } 14537 $outputdir = "display.".$dir_id.".html"; 14538 } 14539 elsif ($define_new_output_dir) 14540#------------------------------------------------------------------------------ 14541# The output directory is defined with the -o option. 14542#------------------------------------------------------------------------------ 14543 { 14544 $outputdir = $g_user_settings{"output"}{"current_value"}; 14545 } 14546 elsif ($overwrite_output_dir) 14547#------------------------------------------------------------------------------ 14548# The output directory is defined with the -O option. 14549#------------------------------------------------------------------------------ 14550 { 14551 $outputdir = $g_user_settings{"overwrite"}{"current_value"}; 14552 } 14553 14554#------------------------------------------------------------------------------ 14555# The name of the output directory is known and we can proceed. 14556#------------------------------------------------------------------------------ 14557 gp_message ("debug", $subr_name, "the target output directory is $outputdir"); 14558 14559 if (-d $outputdir) 14560 { 14561#------------------------------------------------------------------------------ 14562# The -o option is used, but the directory already exists. 14563#------------------------------------------------------------------------------ 14564 if ($define_new_output_dir) 14565 { 14566 $message = "directory $outputdir already exists"; 14567 $message .= " (use the -O option to overwrite an existing directory)"; 14568 push (@g_user_input_errors, $message); 14569 14570 $option_errors++; 14571 14572 return ($option_errors, $outputdir); 14573 } 14574 elsif ($overwrite_output_dir) 14575#------------------------------------------------------------------------------ 14576# It is a bit risky to remove this directory and so we proceed with caution. 14577# What if the user decides to call it "*" e.g. "-O \*" for example? While this 14578# should have been caught when processing the options, we still like to 14579# be very cautious here before executing /bin/rm -rf. 14580#------------------------------------------------------------------------------ 14581 { 14582 if ($outputdir eq "*") 14583 { 14584 $message = "it is not allowed to use * as a value for the -O option"; 14585 push (@g_user_input_errors, $message); 14586 14587 $option_errors++; 14588 14589 return ($option_errors, $outputdir); 14590 } 14591 else 14592 { 14593#------------------------------------------------------------------------------ 14594# The output directory exists, but it is okay to overwrite it. It is 14595# removed here and created again below. 14596#------------------------------------------------------------------------------ 14597 $target_cmd = $g_mapped_cmds{"rm"} . " -rf " . $outputdir; 14598 ($error_code, $rm_output_msg) = execute_system_cmd ($target_cmd); 14599 14600 if ($error_code != 0) 14601 { 14602 gp_message ("error", $subr_name, $rm_output_msg); 14603 gp_message ("abort", $subr_name, "fatal error when trying to remove $outputdir"); 14604 } 14605 else 14606 { 14607 gp_message ("debug", $subr_name, "directory $outputdir has been removed"); 14608 } 14609 } 14610 } 14611 } #-- End of if-check for $outputdir 14612 14613#------------------------------------------------------------------------------- 14614# When we get here, the fatal scenarios have been cleared and the name for 14615# $outputdir is known. Time to create it. Note that recursive creation is 14616# supported and umask controls the access permissions. 14617#------------------------------------------------------------------------------- 14618 $target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir; 14619 ($error_code, $mkdir_output_msg) = execute_system_cmd ($target_cmd); 14620 14621 if ($error_code != 0) 14622 { 14623 my $msg = "a fatal problem occurred when creating directory $outputdir"; 14624 gp_message ("abort", $subr_name, $msg); 14625 } 14626 else 14627 { 14628 gp_message ("debug", $subr_name, "created output directory $outputdir"); 14629 } 14630 14631 return ($option_errors, $outputdir); 14632 14633} #-- End of subroutine set_up_output_directory 14634 14635#------------------------------------------------------------------------------ 14636# Routine to generate webfriendly names 14637#------------------------------------------------------------------------------ 14638sub tag_name 14639{ 14640 my $subr_name = get_my_name (); 14641 14642 my ($target_name) = @_; 14643 14644#------------------------------------------------------------------------------ 14645# Keeps track how many names have been tagged already. 14646#------------------------------------------------------------------------------ 14647 state $S_total_tagged_names = 0; 14648 14649 my $unique_name; 14650 14651 gp_message ("debug", $subr_name, "target_name on entry = $target_name"); 14652 14653#------------------------------------------------------------------------------ 14654# Undo conversion of < in to < 14655#------------------------------------------------------------------------------ 14656 14657#------------------------------------------------------------------------------ 14658# TBD: Legacy - What is going on here and is this really needed?! 14659# We need to replace the "<" symbol in the code by "<". 14660#------------------------------------------------------------------------------ 14661 $target_name =~ s/$g_html_less_than_regex/$g_less_than_regex/g; 14662 14663#------------------------------------------------------------------------------ 14664# Remove inlining info 14665#------------------------------------------------------------------------------ 14666 $target_name =~ s/, instructions from source file.*//; 14667 14668 if (defined $g_tagged_names{$target_name}) 14669 { 14670 gp_message ("debug", $subr_name, "target_name = $target_name is already defined: $g_tagged_names{$target_name}"); 14671 gp_message ("debug", $subr_name, "target_name on return = $target_name"); 14672 return ($g_tagged_names{$target_name}); 14673 } 14674 else 14675 { 14676 $unique_name = "ftag".$S_total_tagged_names; 14677 $S_total_tagged_names++; 14678 $g_tagged_names{$target_name} = $unique_name; 14679 gp_message ("debug", $subr_name, "target_name = $target_name is new and added: g_tagged_names{$target_name} = $g_tagged_names{$target_name}"); 14680 gp_message ("debug", $subr_name, "target_name on return = $target_name"); 14681 return ($unique_name); 14682 } 14683 14684} #-- End of subroutine tag_name 14685 14686#------------------------------------------------------------------------------ 14687# Generate a string to terminate the HTML document. 14688#------------------------------------------------------------------------------ 14689sub terminate_html_document 14690{ 14691 my $subr_name = get_my_name (); 14692 14693 my $html_line; 14694 14695 $html_line = "</body>\n"; 14696 $html_line .= "</html>"; 14697 14698 return (\$html_line); 14699 14700} #-- End of subroutine terminate_html_document 14701 14702#------------------------------------------------------------------------------- 14703# Perform some basic checks to ensure the input data is consistent. This part 14704# could be refined and expanded over time. For example by using a checksum 14705# mechanism to verify the consistency of the executables. 14706#------------------------------------------------------------------------------- 14707sub verify_consistency_experiments 14708{ 14709 my $subr_name = get_my_name (); 14710 14711 my ($exp_dir_list_ref) = @_; 14712 14713 my @exp_dir_list = @{ $exp_dir_list_ref }; 14714 14715 my $executable_name; 14716 my $full_path_executable_name; 14717 my $ref_executable_name; 14718 14719 my $first_exp_dir = $TRUE; 14720 my $count_differences = 0; 14721 14722#------------------------------------------------------------------------------- 14723# Enforce that the full path names to the executable are the same. This could 14724# be overkill and a checksum approach would be more flexible. 14725#------------------------------------------------------------------------------- 14726 for my $full_exp_dir (@exp_dir_list) 14727 { 14728 my $exp_dir = get_basename ($full_exp_dir); 14729 gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); 14730 if ($first_exp_dir) 14731 { 14732 $first_exp_dir = $FALSE; 14733 $ref_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; 14734 gp_message ("debug", $subr_name, "ref_executable_name = $ref_executable_name"); 14735 next; 14736 } 14737 $full_path_executable_name = $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; 14738 gp_message ("debug", $subr_name, "full_path_executable_name = $full_path_executable_name"); 14739 14740 if ($full_path_executable_name ne $ref_executable_name) 14741 { 14742 $count_differences++; 14743 gp_message ("debug", $subr_name, "$full_path_executable_name does not match $ref_executable_name"); 14744 } 14745 } 14746 14747 $executable_name = get_basename ($ref_executable_name); 14748 14749 return ($count_differences, $executable_name); 14750 14751} #-- End of subroutine verify_consistency_experiments 14752 14753#------------------------------------------------------------------------------ 14754# Check if the input item is valid for the data type specified. Validity is 14755# verified in the context of gprofng. The definition for the metrics is a 14756# good example of that. 14757#------------------------------------------------------------------------------ 14758sub verify_if_input_is_valid 14759{ 14760 my $subr_name = get_my_name (); 14761 14762 my ($input_item, $data_type) = @_; 14763 14764 my $return_value = $FALSE; 14765 14766#------------------------------------------------------------------------------ 14767# These value are allowed to be case insensitive, so we convert to lower 14768# case first. 14769#------------------------------------------------------------------------------ 14770 if (($data_type eq "onoff") or ($data_type eq "size")) 14771 { 14772 $input_item = lc ($input_item); 14773 } 14774 14775 if ($data_type eq "metrics") 14776#------------------------------------------------------------------------------ 14777# A gprofng metric definition. Either consists of "default" only, or starts 14778# with e or i, followed by one or more from the set {.,%,!,+} and a keyword. 14779# This pattern may be repeated with a ":" as the separator. 14780#------------------------------------------------------------------------------ 14781 { 14782 my @metric_list = split (":", $input_item); 14783 14784#------------------------------------------------------------------------------ 14785# Check if the pattern is valid. If not, bail out and return $FALSE. 14786#------------------------------------------------------------------------------ 14787 for my $metric (@metric_list) 14788 { 14789 if ($metric =~ /^default$|^[ei]*[\.%\!\+]+[a-z]*$/) 14790 { 14791 $return_value = $TRUE; 14792 } 14793 else 14794 { 14795 $return_value = $FALSE; 14796 last; 14797 } 14798 } 14799 } 14800 elsif ($data_type eq "metric_names") 14801#------------------------------------------------------------------------------ 14802# A gprofng metric definition but without the flavour and visibility . Either 14803# the name consists of "default" only, or a keyword with lowercase letters 14804# only. This pattern may be repeated with a ":" as the separator. 14805#------------------------------------------------------------------------------ 14806 { 14807 my @metric_list = split (":", $input_item); 14808 14809#------------------------------------------------------------------------------ 14810# Check if the pattern is valid. If not, bail out and return $FALSE. 14811#------------------------------------------------------------------------------ 14812 for my $metric (@metric_list) 14813 { 14814 if ($metric =~ /^default$|^[a-z]*$/) 14815 { 14816 $return_value = $TRUE; 14817 } 14818 else 14819 { 14820 $return_value = $FALSE; 14821 last; 14822 } 14823 } 14824 } 14825 elsif ($data_type eq "path") 14826#------------------------------------------------------------------------------ 14827# This can be almost anything, including "/" and "." 14828#------------------------------------------------------------------------------ 14829 { 14830 if ($input_item =~ /^[\w\/\.]*$/) 14831 { 14832 $return_value = $TRUE; 14833 } 14834 } 14835 elsif ($data_type eq "boolean") 14836 { 14837#------------------------------------------------------------------------------ 14838# This is TRUE (=1) or FALSE (0). 14839#------------------------------------------------------------------------------ 14840 if ($input_item =~ /^[01]$/) 14841 { 14842 $return_value = $TRUE; 14843 } 14844 } 14845 elsif ($data_type eq "onoff") 14846#------------------------------------------------------------------------------ 14847# This is either "on" OR "off". 14848#------------------------------------------------------------------------------ 14849 { 14850 if ($input_item =~ /^on$|^off$/) 14851 { 14852 $return_value = $TRUE; 14853 } 14854 } 14855 elsif ($data_type eq "size") 14856#------------------------------------------------------------------------------ 14857# Supported values are "on", "off", "s", "m", "l", OR "xl". 14858#------------------------------------------------------------------------------ 14859 { 14860 if ($input_item =~ /^on$|^off$|^s$|^m$|^l$|^xl$/) 14861 { 14862 $return_value = $TRUE; 14863 } 14864 } 14865 elsif ($data_type eq "pinteger") 14866#------------------------------------------------------------------------------ 14867# This is a positive integer. 14868#------------------------------------------------------------------------------ 14869 { 14870 if ($input_item =~ /^\d*$/) 14871 { 14872 $return_value = $TRUE; 14873 } 14874 } 14875 elsif ($data_type eq "integer") 14876#------------------------------------------------------------------------------ 14877# This is a positive or negative integer. 14878#------------------------------------------------------------------------------ 14879 { 14880 if ($input_item =~ /^\-?\d*$/) 14881 { 14882 $return_value = $TRUE; 14883 } 14884 } 14885 elsif ($data_type eq "pfloat") 14886#------------------------------------------------------------------------------ 14887# This is a positive floating point number, but we accept a positive integer 14888# number as well. 14889# 14890# TBD: Note that we use the "." here. Maybe should support a "," too. 14891#------------------------------------------------------------------------------ 14892 { 14893 if (($input_item =~ /^\d*\.\d*$/) or ($input_item =~ /^\d*$/)) 14894 { 14895 $return_value = $TRUE; 14896 } 14897 } 14898 elsif ($data_type eq "float") 14899#------------------------------------------------------------------------------ 14900# This is a positive or negative floating point number, but we accept an 14901# integer number as well. 14902# 14903# TBD: Note that we use the "." here. Maybe should support a "," too. 14904#------------------------------------------------------------------------------ 14905 { 14906 if (($input_item =~ /^\-?\d*\.\d*$/) or ($input_item =~ /^\-?\d*$/)) 14907 { 14908 $return_value = $TRUE; 14909 } 14910 } 14911 else 14912 { 14913 my $msg = "the $data_type data type for input $input_item is not supported"; 14914 gp_message ("assertion", $subr_name, $msg); 14915 } 14916 14917 return ($return_value); 14918 14919} #-- End of subroutine verify_if_input_is_valid 14920