1#!/usr/bin/env perl 2# Copyright (C) 2021-2023 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; 24 25# Disable before release 26# use Perl::Critic; 27 28use bignum; 29use List::Util qw (max); 30use Cwd qw (abs_path cwd); 31use File::Basename; 32use File::stat; 33use feature qw (state); 34use POSIX; 35use Getopt::Long qw (Configure); 36 37#------------------------------------------------------------------------------ 38# Check as early as possible if the version of Perl used is supported. 39#------------------------------------------------------------------------------ 40INIT 41{ 42 my $perl_minimal_version_supported = version->parse ("5.10.0")->normal; 43 my $perl_current_version = version->parse ("$]")->normal; 44 45 if ($perl_current_version lt $perl_minimal_version_supported) 46 { 47 my $msg; 48 49 $msg = "Error: minimum Perl release required: "; 50 $msg .= $perl_minimal_version_supported; 51 $msg .= " current: "; 52 $msg .= $perl_current_version; 53 $msg .= "\n"; 54 55 print $msg; 56 57 exit (1); 58 } 59} #-- End of INIT 60 61#------------------------------------------------------------------------------ 62# Poor man's version of a boolean. 63#------------------------------------------------------------------------------ 64my $TRUE = 1; 65my $FALSE = 0; 66 67#------------------------------------------------------------------------------ 68# The total number of functions to be processed. 69#------------------------------------------------------------------------------ 70my $g_total_function_count = 0; 71 72#------------------------------------------------------------------------------ 73# Used to ensure correct alignment of columns. 74#------------------------------------------------------------------------------ 75my $g_max_length_first_metric; 76 77#------------------------------------------------------------------------------ 78# This variable contains the path used to execute $GP_DISPAY_TEXT. 79#------------------------------------------------------------------------------ 80my $g_path_to_tools; 81 82#------------------------------------------------------------------------------ 83# Code debugging flag. 84#------------------------------------------------------------------------------ 85my $g_test_code = $FALSE; 86 87#------------------------------------------------------------------------------ 88# GPROFNG commands and files used. 89#------------------------------------------------------------------------------ 90my $GP_DISPLAY_TEXT = "gp-display-text"; 91 92my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log"; 93my $g_gp_error_logfile = $GP_DISPLAY_TEXT.".stderr.log"; 94 95#------------------------------------------------------------------------------ 96# Global variables. 97#------------------------------------------------------------------------------ 98my $g_addressing_mode = "64 bit"; 99 100#------------------------------------------------------------------------------ 101# The global regex section. 102# 103# First step towards consolidating all regexes. 104#------------------------------------------------------------------------------ 105 my $g_less_than_regex = '<'; 106 my $g_html_less_than_regex = '<'; 107 my $g_endbr_inst_regex = 'endbr[32|64]'; 108 my $g_rm_surrounding_spaces_regex = '^\s+|\s+$'; 109 110#------------------------------------------------------------------------------ 111# For consistency, use a global variable. 112#------------------------------------------------------------------------------ 113 my $g_html_new_line = "<br>"; 114 115#------------------------------------------------------------------------------ 116# These are the regex's used. 117#------------------------------------------------------------------------------ 118#------------------------------------------------------------------------------ 119# Disassembly analysis 120#------------------------------------------------------------------------------ 121 my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; 122 my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; 123 my $g_function_call_v2_regex = 124 '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; 125 126my $g_first_metric; 127 128my $binutils_version; 129my $driver_cmd; 130my $tool_name; 131my $version_info; 132 133my %g_mapped_cmds = (); 134 135#------------------------------------------------------------------------------ 136# Variables dealing with warnings and errors. Since a message may span 137# multiple lines (for readability reasons), the number of entries in the 138# array may not reflect the total number of messages. This is why we use 139# separate variables for the counts. 140#------------------------------------------------------------------------------ 141my @g_error_msgs = (); 142my @g_warning_msgs = (); 143my $g_total_error_count = 0; 144#------------------------------------------------------------------------------ 145# This count is used in the html_create_warnings_page HTML page to show how 146# many warning messages there are. Warnings are printed through gp_message(), 147# but since one warning may span multiple lines, we update a separate counter 148# that contains the total number of warning messages issued so far. 149#------------------------------------------------------------------------------ 150my $g_total_warning_count = 0; 151my $g_options_printed = $FALSE; 152my $g_abort_msg = "cannot recover from the error(s)"; 153 154#------------------------------------------------------------------------------ 155# Contains the names that have already been tagged. This is a global 156# structure because otherwise the code would get much more complicated. 157#------------------------------------------------------------------------------ 158my %g_tagged_names = (); 159 160#------------------------------------------------------------------------------ 161# TBD Remove the use of these structures. No longer used. 162#------------------------------------------------------------------------------ 163my %g_function_tag_id = (); 164my $g_context = 5; # Defines the range of scan 165 166my $g_default_setting_lang = "en-US.UTF-8"; 167my %g_exp_dir_meta_data; 168 169my $g_html_credits_line; 170 171my $g_warn_keyword = "[Warning]"; 172my $g_error_keyword = "[Error]"; 173 174my %g_function_occurrences = (); 175my %g_map_function_to_index = (); 176my %g_multi_count_function = (); 177my %g_function_view_all = (); 178my @g_full_function_view_table = (); 179 180my @g_html_experiment_stats = (); 181 182#------------------------------------------------------------------------------ 183# These structures contain the information printed in the function views. 184#------------------------------------------------------------------------------ 185my $g_header_lines; 186 187my @g_html_function_name = (); 188 189#------------------------------------------------------------------------------ 190# TBD: This variable may not be needed and replaced by tp_value 191my $thresh = 0; 192#------------------------------------------------------------------------------ 193 194#------------------------------------------------------------------------------ 195# Define the driver command, tool name and version number. 196#------------------------------------------------------------------------------ 197$driver_cmd = "gprofng display html"; 198$tool_name = "gp-display-html"; 199#$binutils_version = "2.38.50"; 200$binutils_version = "BINUTILS_VERSION"; 201$version_info = $tool_name . " GNU binutils version " . $binutils_version; 202 203#------------------------------------------------------------------------------ 204 205#------------------------------------------------------------------------------ 206#------------------------------------------------------------------------------ 207# Define several key data structures. 208#------------------------------------------------------------------------------ 209#------------------------------------------------------------------------------ 210 211#------------------------------------------------------------------------------ 212# This table has the settings of the variables the user may set. 213#------------------------------------------------------------------------------ 214my %g_user_settings = 215 ( 216 verbose => { option => "--verbose", 217 no_of_arguments => 1, 218 data_type => "onoff", 219 current_value => "off", defined => $FALSE}, 220 221 debug => { option => "--debug", 222 no_of_arguments => 1, 223 data_type => "size", 224 current_value => "off", defined => $FALSE}, 225 226 warnings => { option => "--warnings", 227 no_of_arguments => 1, 228 data_type => "onoff" , 229 current_value => "off", defined => $FALSE}, 230 231 nowarnings => { option => "--nowarnings", 232 no_of_arguments => 1, 233 data_type => "onoff", 234 current_value => "off", defined => $FALSE}, 235 236 quiet => { option => "--quiet", 237 no_of_arguments => 1, 238 data_type => "onoff", 239 current_value => "off", defined => $FALSE}, 240 241 output => { option => "-o", 242 no_of_arguments => 1, 243 data_type => "path", 244 current_value => undef, defined => $FALSE}, 245 246 overwrite => { option => "-O", 247 no_of_arguments => 1, 248 data_type => "path", 249 current_value => undef, defined => $FALSE}, 250 251 calltree => { option => "-ct", 252 no_of_arguments => 1, 253 data_type => "onoff", 254 current_value => "off", defined => $FALSE}, 255 256 func_limit => { option => "-fl", 257 no_of_arguments => 1, 258 data_type => "pinteger", 259 current_value => 500, defined => $FALSE}, 260 261 highlight_percentage => { option => "--highlight-percentage", 262 no_of_arguments => 1, 263 data_type => "pfloat", 264 current_value => 90.0, defined => $FALSE}, 265 266 hp => { option => "-hp", 267 no_of_arguments => 1, 268 data_type => "pfloat", 269 current_value => 90.0, defined => $FALSE}, 270 271 threshold_percentage => { option => "-tp", 272 no_of_arguments => 1, 273 data_type => "pfloat", 274 current_value => 100.0, defined => $FALSE}, 275 276 default_metrics => { option => "-dm", 277 no_of_arguments => 1, 278 data_type => "onoff", 279 current_value => "off", defined => $FALSE}, 280 281 ignore_metrics => { option => "-im", 282 no_of_arguments => 1, 283 data_type => "metric_names", 284 current_value => undef, defined => $FALSE}, 285 ); 286 287#------------------------------------------------------------------------------ 288# Convenience. These map the on/off value to $TRUE/$FALSE to make the code 289# easier to read. For example: "if ($g_verbose)" as opposed to the following: 290# "if ($verbose_setting eq "on"). 291#------------------------------------------------------------------------------ 292my $g_verbose = $FALSE; 293my $g_debug = $FALSE; 294my $g_warnings = $TRUE; 295my $g_quiet = $FALSE; 296 297#------------------------------------------------------------------------------ 298# Since ARGV is modified when parsing the options, a clean copy is used to 299# print the original ARGV values in case of a warning, or error. 300#------------------------------------------------------------------------------ 301my @CopyOfARGV = (); 302 303my %g_debug_size = 304 ( 305 "on" => $FALSE, 306 "s" => $FALSE, 307 "m" => $FALSE, 308 "l" => $FALSE, 309 "xl" => $FALSE, 310 ); 311 312my %local_system_config = 313 ( 314 kernel_name => "undefined", 315 nodename => "undefined", 316 kernel_release => "undefined", 317 kernel_version => "undefined", 318 machine => "undefined", 319 processor => "undefined", 320 hardware_platform => "undefined", 321 operating_system => "undefined", 322 hostname_current => "undefined", 323 ); 324 325#------------------------------------------------------------------------------ 326# Note that we use single quotes here, because regular expressions wreak 327# havoc otherwise. 328#------------------------------------------------------------------------------ 329 330my %g_arch_specific_settings = 331 ( 332 arch_supported => $FALSE, 333 arch => 'undefined', 334 regex => 'undefined', 335 subexp => 'undefined', 336 linksubexp => 'undefined', 337 ); 338 339my %g_locale_settings = ( 340 LANG => "en_US.UTF-8", 341 decimal_separator => "\\.", 342 covert_to_dot => $FALSE 343); 344 345#------------------------------------------------------------------------------ 346# See this page for a nice overview with the colors: 347# https://www.w3schools.com/colors/colors_groups.asp 348#------------------------------------------------------------------------------ 349 350my %g_html_color_scheme = ( 351 "control_flow" => "Brown", 352 "target_function_name" => "Red", 353 "non_target_function_name" => "BlueViolet", 354 "background_color_hot" => "PeachPuff", 355 "background_color_lukewarm" => "LemonChiffon", 356 "link_outside_range" => "Crimson", 357 "error_message" => "LightPink", 358 "background_color_page" => "White", 359# "background_color_page" => "LightGray", 360 "background_selected_sort" => "LightSlateGray", 361 "index" => "Lavender", 362); 363 364#------------------------------------------------------------------------------ 365# These are the base names for the HTML files that are generated. 366#------------------------------------------------------------------------------ 367my %g_html_base_file_name = ( 368 "caller_callee" => "caller-callee", 369 "disassembly" => "dis", 370 "experiment_info" => "experiment-info", 371 "function_view" => "function-view-sorted", 372 "index" => "index", 373 "source" => "src", 374 "warnings" => "warnings", 375); 376 377#------------------------------------------------------------------------------ 378# Introducing main() is cosmetic, but helps with the scoping of variables. 379#------------------------------------------------------------------------------ 380 main (); 381 382 exit (0); 383 384#------------------------------------------------------------------------------ 385# This is the driver part of the program. 386#------------------------------------------------------------------------------ 387sub main 388{ 389 my $subr_name = get_my_name (); 390 391 @CopyOfARGV = @ARGV; 392 393#------------------------------------------------------------------------------ 394# The name of the configuration file. 395#------------------------------------------------------------------------------ 396 my $rc_file_name = ".gp-display-html.rc"; 397 398#------------------------------------------------------------------------------ 399# OS commands executed and search paths. 400# 401# TBD: check if elfdump should be here too (most likely not though) 402#------------------------------------------------------------------------------ 403 my @selected_os_cmds = qw (rm cat hostname locale which printenv uname 404 readelf mkdir); 405 406 my @search_paths_os_cmds = qw ( 407 /usr/bin 408 /bin 409 /usr/local/bin 410 /usr/local/sbin 411 /usr/sbin 412 /sbin 413 ); 414 415#------------------------------------------------------------------------------ 416# TBD: Eliminate these. 417#------------------------------------------------------------------------------ 418 my $ARCHIVES_MAP_NAME; 419 my $ARCHIVES_MAP_VADDR; 420 421#------------------------------------------------------------------------------ 422# Local structures (hashes and arrays). 423#------------------------------------------------------------------------------ 424 my @exp_dir_list = (); 425 my @metrics_data; 426 427 my %function_address_info = (); 428 my $function_address_info_ref; 429 430 my @function_info = (); 431 my $function_info_ref; 432 433 my %function_address_and_index = (); 434 my $function_address_and_index_ref; 435 436 my %addressobjtextm = (); 437 my $addressobjtextm_ref; 438 439 my %addressobj_index = (); 440 my $addressobj_index_ref; 441 442 my %LINUX_vDSO = (); 443 my $LINUX_vDSO_ref; 444 445 my %function_view_structure = (); 446 my $function_view_structure_ref; 447 448 my %elf_rats = (); 449 my $elf_rats_ref; 450 451#------------------------------------------------------------------------------ 452# Local variables. 453#------------------------------------------------------------------------------ 454 my $abs_path_outputdir; 455 my $archive_dir_not_empty; 456 my $base_va_executable; 457 my $executable_name; 458 my $found_exp_dir; 459 my $ignore_value; 460 my $msg; 461 my $number_of_metrics; 462 my $va_executable_in_hex; 463 464 my $failed_command_mappings; 465 466 my $script_pc_metrics; 467 my $dir_check_errors; 468 my $consistency_errors; 469 my $outputdir; 470 my $return_code; 471 472 my $decimal_separator; 473 my $convert_to_dot; 474 my $architecture_supported; 475 my $elf_arch; 476 my $elf_support; 477 my $home_dir; 478 my $elf_loadobjects_found; 479 480 my $rc_file_paths_ref; 481 my @rc_file_paths = (); 482 my $rc_file_errors = 0; 483 484 my @sort_fields = (); 485 my $summary_metrics; 486 my $call_metrics; 487 my $user_metrics; 488 my $system_metrics; 489 my $wall_metrics; 490 my $detail_metrics; 491 my $detail_metrics_system; 492 493 my $html_test; 494 my @experiment_data; 495 my $exp_info_file; 496 my $exp_info_ref; 497 my @exp_info; 498 499 my $pretty_dir_list; 500 501 my %metric_value = (); 502 my %metric_description = (); 503 my %metric_description_reversed = (); 504 my %metric_found = (); 505 my %ignored_metrics = (); 506 507 my $metric_value_ref; 508 my $metric_description_ref; 509 my $metric_found_ref; 510 my $ignored_metrics_ref; 511 512 my @table_execution_stats = (); 513 my $table_execution_stats_ref; 514 515 my $html_first_metric_file_ref; 516 my $html_first_metric_file; 517 518 my $arch; 519 my $subexp; 520 my $linksubexp; 521 522 my $setting_for_LANG; 523 my $time_percentage_multiplier; 524 my $process_all_functions; 525 526 my $selected_archive; 527 528#------------------------------------------------------------------------------ 529# If no options are given, print the help info and exit. 530#------------------------------------------------------------------------------ 531 if ($#ARGV == -1) 532 { 533 $ignore_value = print_help_info (); 534 return (0); 535 } 536 537#------------------------------------------------------------------------------ 538# This part is like a preamble. Before we continue we need to figure out some 539# things that are needed later on. 540#------------------------------------------------------------------------------ 541 542#------------------------------------------------------------------------------ 543# Store the absolute path of the command executed. 544#------------------------------------------------------------------------------ 545 my $location_gp_command = $0; 546 547#------------------------------------------------------------------------------ 548# Get the ball rolling. Parse and interpret the options. Some first checks 549# are performed. 550# 551# Instead of bailing out on the first user error, we capture all warnings and 552# errors. The warnings, if any, will be printed once the command line has 553# been parsed and verified. Execution continues. 554# 555# Any error(s) accumulated in this phase will be printed after the command 556# line has been parsed and verified. Execution is then terminated. 557# 558# In the remainder, any error encountered will immediately terminate the 559# execution because we can't guarantee the remaining code will work up to 560# some point. 561#------------------------------------------------------------------------------ 562 my ($found_exp_dir_ref, $exp_dir_list_ref) = parse_and_check_user_options (); 563 564 $found_exp_dir = ${ $found_exp_dir_ref }; 565 566 if ($found_exp_dir) 567 { 568 @exp_dir_list = @{ $exp_dir_list_ref }; 569 } 570 else 571 { 572 $msg = "the list with experiments is either missing, or incorrect"; 573 gp_message ("debug", $subr_name, $msg); 574 } 575 576#------------------------------------------------------------------------------ 577# The final settings for verbose, debug, warnings and quiet are known and the 578# gp_message() subroutine is aware of these. 579#------------------------------------------------------------------------------ 580 $msg = "parsing of the user options completed"; 581 gp_message ("verbose", $subr_name, $msg); 582 583#------------------------------------------------------------------------------ 584# The user options have been taken in. Check for validity and consistency. 585#------------------------------------------------------------------------------ 586 $msg = "process user options"; 587 gp_message ("verbose", $subr_name, $msg); 588 589 ($ignored_metrics_ref, $outputdir, 590 $time_percentage_multiplier, $process_all_functions, $exp_dir_list_ref) = 591 process_user_options (\@exp_dir_list); 592 593 @exp_dir_list = @{ $exp_dir_list_ref }; 594 %ignored_metrics = %{$ignored_metrics_ref}; 595 596#------------------------------------------------------------------------------ 597# The next subroutine is executed early to ensure the OS commands we need are 598# available. 599# 600# This subroutine stores the commands and the full path names as an 601# associative array called "g_mapped_cmds". The command is the key and the 602# value is the full path. For example: ("uname", /usr/bin/uname). 603#------------------------------------------------------------------------------ 604 gp_message ("debug", $subr_name, "verify the OS commands"); 605 $failed_command_mappings = check_and_define_cmds (\@selected_os_cmds, 606 \@search_paths_os_cmds); 607 608 if ($failed_command_mappings == 0) 609 { 610 $msg = "successfully verified the OS commands"; 611 gp_message ("debug", $subr_name, $msg); 612 } 613 614#------------------------------------------------------------------------------ 615#------------------------------------------------------------------------------ 616# Time to check if any warnings and/or errors have been generated. 617#------------------------------------------------------------------------------ 618#------------------------------------------------------------------------------ 619 620#------------------------------------------------------------------------------ 621# We have completed all the upfront checks. Print any warnings and errors. 622# If there are already any errors, execution is terminated. As execution 623# continues, errors may occur and they are typically fatal. 624#------------------------------------------------------------------------------ 625 if ($g_debug) 626 { 627 $msg = "internal settings after option processing"; 628 $ignore_value = print_table_user_settings ("diag", $msg); 629 } 630 631#------------------------------------------------------------------------------ 632# Terminate execution in case fatal errors have occurred. 633#------------------------------------------------------------------------------ 634 if ( $g_total_error_count > 0) 635 { 636 my $msg = "the current values for the user controllable settings"; 637 print_user_settings ("debug", $msg); 638 639 gp_message ("abort", $subr_name, $g_abort_msg); 640 } 641 else 642 { 643 my $msg = "after parsing the user options, the final values are"; 644 print_user_settings ("debug", $msg); 645 } 646 647#------------------------------------------------------------------------------ 648# If no option is given for the output directory, pick a default. Otherwise, 649# if the output directory exists, wipe it clean in case the -O option is used. 650# If not, raise an error because the -o option does not overwrite an existing 651# directory. 652# Also in case of other errors, the execution is terminated. 653#------------------------------------------------------------------------------ 654 $outputdir = set_up_output_directory (); 655 $abs_path_outputdir = Cwd::cwd () . "/" . $outputdir; 656 657 $msg = "the output directory is $outputdir"; 658 gp_message ("debug", $subr_name, $msg); 659 660#------------------------------------------------------------------------------ 661# Get the home directory and the locations for the configuration file on the 662# current system. 663#------------------------------------------------------------------------------ 664 ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path ($rc_file_name); 665 666 @rc_file_paths = @{ $rc_file_paths_ref }; 667 668 $msg = "the home directory is $home_dir"; 669 gp_message ("debug", $subr_name, $msg); 670 671#------------------------------------------------------------------------------ 672# TBD: de-activated until this feature has been fully implemented. 673#------------------------------------------------------------------------------ 674## $msg = "the search path for the rc file is @rc_file_paths"; 675## gp_message ("debug", $subr_name, $msg); 676## $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths); 677 678#------------------------------------------------------------------------------ 679# Get the ball rolling. Parse and interpret the configuration file (if any) 680# and the command line options. 681# 682# Note that the verbose, debug, and quiet options can be set in this file. 683# It is a deliberate choice to ignore these for now. The assumption is that 684# the user will not be happy if we ignore the command line settings for a 685# while. 686#------------------------------------------------------------------------------ 687 $msg = "processing of the rc file has been disabled for now"; 688 gp_message ("debugXL", $subr_name, $msg); 689 690# Temporarily disabled 691# print_table_user_settings ("debugXL", "before function process_rc_file"); 692# $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref); 693# if ($rc_file_errors != 0) 694# { 695# $message = "fatal errors in file $rc_file_name encountered"; 696# gp_message ("debugXL", $subr_name, $message); 697# } 698# print_table_user_settings ("debugXL", "after function process_rc_file"); 699 700#------------------------------------------------------------------------------ 701# Print a list with the experiment directory names 702#------------------------------------------------------------------------------ 703 $pretty_dir_list = build_pretty_dir_list (\@exp_dir_list); 704 705 my $plural = ($#exp_dir_list > 0) ? "directories are" : "directory is"; 706 707 $msg = "the experiment " . $plural . ":"; 708 gp_message ("verbose", $subr_name, $msg); 709 gp_message ("verbose", $subr_name, $pretty_dir_list); 710 711#------------------------------------------------------------------------------ 712# Set up the first entry with the meta data for the experiments. This field 713# contains the absolute paths to the experiment directories. 714#------------------------------------------------------------------------------ 715 for my $exp_dir (@exp_dir_list) 716 { 717 my ($filename, $directory_path, $ignore_suffix) = fileparse ($exp_dir); 718 gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); 719 gp_message ("debug", $subr_name, "filename = $filename"); 720 gp_message ("debug", $subr_name, "directory_path = $directory_path"); 721 $g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path; 722 } 723 724#------------------------------------------------------------------------------ 725# TBD: 726# This subroutine may be overkill. See what is really needed here and remove 727# everything else. 728# 729# Upon return, one directory has been selected to be used in the remainder. 730# This is not always the correct thing to do, but is the same as the original 731# code. In due time this should be addressed though. 732#------------------------------------------------------------------------------ 733 ($archive_dir_not_empty, $selected_archive, $elf_rats_ref) = 734 check_validity_exp_dirs (\@exp_dir_list); 735 736 %elf_rats = %{$elf_rats_ref}; 737 738 $msg = "the experiment directories have been verified and are valid"; 739 gp_message ("verbose", $subr_name, $msg); 740 741#------------------------------------------------------------------------------ 742# Now that we know the map.xml file(s) are present, we can scan these and get 743# the required information. This includes setting the base virtual address. 744#------------------------------------------------------------------------------ 745 $ignore_value = determine_base_virtual_address ($exp_dir_list_ref); 746 747#------------------------------------------------------------------------------ 748# Check whether the experiment directories are consistent. 749#------------------------------------------------------------------------------ 750 ($consistency_errors, $executable_name) = 751 verify_consistency_experiments ($exp_dir_list_ref); 752 753 if ($consistency_errors == 0) 754 { 755 $msg = "the experiment directories are consistent"; 756 gp_message ("verbose", $subr_name, $msg); 757 } 758 else 759 { 760 $msg = "the number of consistency errors detected: $consistency_errors"; 761 gp_message ("abort", $subr_name, $msg); 762 } 763 764#------------------------------------------------------------------------------ 765# The directories are consistent. We can now set the base virtual address of 766# the executable. 767#------------------------------------------------------------------------------ 768 $base_va_executable = 769 $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"}; 770 771 $msg = "executable_name = " . $executable_name; 772 gp_message ("debug", $subr_name, $msg); 773 $msg = "selected_archive = " . $selected_archive; 774 gp_message ("debug", $subr_name, $msg); 775 $msg = "base_va_executable = " . $base_va_executable; 776 gp_message ("debug", $subr_name, $msg); 777 778#------------------------------------------------------------------------------ 779# The $GP_DISPLAY_TEXT tool is critical and has to be available in order to 780# proceed. 781# This subroutine only returns a value if the tool can be found. 782#------------------------------------------------------------------------------ 783 $g_path_to_tools = ${ check_availability_tool (\$location_gp_command)}; 784 785 $GP_DISPLAY_TEXT = $g_path_to_tools . $GP_DISPLAY_TEXT; 786 787 $msg = "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT"; 788 gp_message ("debug", $subr_name, $msg); 789 790#------------------------------------------------------------------------------ 791# Check if $GP_DISPLAY_TEXT is executable for user, group, and other. 792# If not, print a warning only, since this may not be fatal but could 793# potentially lead to issues later on. 794#------------------------------------------------------------------------------ 795 if (not is_file_executable ($GP_DISPLAY_TEXT)) 796 { 797 $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and"; 798 $msg .= " other"; 799 gp_message ("warning", $subr_name, $msg); 800 } 801 802#------------------------------------------------------------------------------ 803# Find out what the decimal separator is, as set by the user. 804#------------------------------------------------------------------------------ 805 ($return_code, $decimal_separator, $convert_to_dot) = 806 determine_decimal_separator (); 807 808 if ($return_code == 0) 809 { 810 $msg = "decimal separator is $decimal_separator"; 811 $msg .= " (conversion to dot is "; 812 $msg .= ($convert_to_dot == $TRUE ? "enabled" : "disabled") . ")"; 813 gp_message ("debugXL", $subr_name, $msg); 814 } 815 else 816 { 817 $msg = "the decimal separator cannot be determined -"; 818 $msg .= " set to $decimal_separator"; 819 gp_message ("warning", $subr_name, $msg); 820 } 821 822#------------------------------------------------------------------------------ 823# Collect and store the system information. 824#------------------------------------------------------------------------------ 825 $msg = "collect system information and adapt settings"; 826 gp_message ("verbose", $subr_name, $msg); 827 828 $return_code = get_system_config_info (); 829 830#------------------------------------------------------------------------------ 831# The 3 variables below are used in the remainder. 832# 833# The output from "uname -p" is recommended to be used for the ISA. 834#------------------------------------------------------------------------------ 835 my $hostname_current = $local_system_config{hostname_current}; 836 my $arch_uname_s = $local_system_config{kernel_name}; 837 my $arch_uname = $local_system_config{processor}; 838 839 gp_message ("debug", $subr_name, "set hostname_current = $hostname_current"); 840 gp_message ("debug", $subr_name, "set arch_uname_s = $arch_uname_s"); 841 gp_message ("debug", $subr_name, "set arch_uname = $arch_uname"); 842 843#------------------------------------------------------------------------------ 844# This function also sets the values in "g_arch_specific_settings". This 845# includes several definitions of regular expressions. 846#------------------------------------------------------------------------------ 847 ($architecture_supported, $elf_arch, $elf_support) = 848 set_system_specific_variables ($arch_uname, $arch_uname_s); 849 850 $msg = "architecture_supported = $architecture_supported"; 851 gp_message ("debug", $subr_name, $msg); 852 $msg = "elf_arch = $elf_arch"; 853 gp_message ("debug", $subr_name, $msg); 854 $msg = "elf_support = ".($elf_arch ? "TRUE" : "FALSE"); 855 gp_message ("debug", $subr_name, $msg); 856 857 for my $feature (sort keys %g_arch_specific_settings) 858 { 859 $msg = "g_arch_specific_settings{$feature} = "; 860 $msg .= $g_arch_specific_settings{$feature}; 861 gp_message ("debug", $subr_name, $msg); 862 } 863 864 $arch = $g_arch_specific_settings{"arch"}; 865 $subexp = $g_arch_specific_settings{"subexp"}; 866 $linksubexp = $g_arch_specific_settings{"linksubexp"}; 867 868 $g_locale_settings{"LANG"} = get_LANG_setting (); 869 870 $msg = "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}"; 871 gp_message ("debugXL", $subr_name, $msg); 872 873#------------------------------------------------------------------------------ 874# Temporarily reset selected settings since these are not yet implemented. 875#------------------------------------------------------------------------------ 876 $ignore_value = reset_selected_settings (); 877 878#------------------------------------------------------------------------------ 879# TBD: Revisit. Is this really necessary? 880#------------------------------------------------------------------------------ 881 882 ($executable_name, $va_executable_in_hex) = 883 check_loadobjects_are_elf ($selected_archive); 884 $elf_loadobjects_found = $TRUE; 885 886# TBD: Hack and those ARCHIVES_ names can be eliminated 887 $ARCHIVES_MAP_NAME = $executable_name; 888 $ARCHIVES_MAP_VADDR = $va_executable_in_hex; 889 890 $msg = "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"; 891 gp_message ("debugXL", $subr_name, $msg); 892 $msg = "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"; 893 gp_message ("debugXL", $subr_name, $msg); 894 895 $msg = "after call to check_loadobjects_are_elf forced"; 896 $msg .= " elf_loadobjects_found = $elf_loadobjects_found"; 897 gp_message ("debugXL", $subr_name, $msg); 898 899 $g_html_credits_line = ${ create_html_credits () }; 900 901 $msg = "g_html_credits_line = $g_html_credits_line"; 902 gp_message ("debugXL", $subr_name, $msg); 903 904#------------------------------------------------------------------------------ 905# Add a "/" to simplify the construction of path names in the remainder. 906# 907# TBD: Push this into a subroutine(s). 908#------------------------------------------------------------------------------ 909 $outputdir = append_forward_slash ($outputdir); 910 911 gp_message ("debug", $subr_name, "prepared outputdir = $outputdir"); 912 913#------------------------------------------------------------------------------ 914#------------------------------------------------------------------------------ 915# ******* TBD: e.system not available on Linux!! 916#------------------------------------------------------------------------------ 917#------------------------------------------------------------------------------ 918 919## my $summary_metrics = 'e.totalcpu'; 920 $detail_metrics = 'e.totalcpu'; 921 $detail_metrics_system = 'e.totalcpu:e.system'; 922 $call_metrics = 'a.totalcpu'; 923 924 my $cmd_options; 925 my $metrics_cmd; 926 927 my $outfile1 = $outputdir ."metrics"; 928 my $outfile2 = $outputdir . "metrictotals"; 929 my $gp_error_file = $outputdir . $g_gp_error_logfile; 930 931#------------------------------------------------------------------------------ 932# Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is 933# to get all the output in files $outfile1 and $outfile2. These are then 934# parsed. 935#------------------------------------------------------------------------------ 936 $msg = "gather the metrics data from the experiments"; 937 gp_message ("verbose", $subr_name, $msg); 938 939 $return_code = get_metrics_data (\@exp_dir_list, $outputdir, $outfile1, 940 $outfile2, $gp_error_file); 941 942 if ($return_code != 0) 943 { 944 gp_message ("abort", $subr_name, "execution terminated"); 945 } 946 947#------------------------------------------------------------------------------ 948# TBD: Test this code 949#------------------------------------------------------------------------------ 950 $msg = "unable to open metric value data file $outfile1 for reading:"; 951 open (METRICS, "<", $outfile1) 952 or die ($subr_name . " - " . $msg . " " . $!); 953 954 $msg = "opened file $outfile1 for reading"; 955 gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); 956 957 chomp (@metrics_data = <METRICS>); 958 close (METRICS); 959 960 for my $i (keys @metrics_data) 961 { 962 $msg = "metrics_data[$i] = " . $metrics_data[$i]; 963 gp_message ("debugXL", $subr_name, $msg); 964 } 965 966#------------------------------------------------------------------------------ 967# Process the generated metrics data. 968#------------------------------------------------------------------------------ 969 if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") 970 971#------------------------------------------------------------------------------ 972# The metrics will be derived from the experiments. 973#------------------------------------------------------------------------------ 974 { 975 gp_message ("verbose", $subr_name, "Process the metrics data"); 976 977 ($metric_value_ref, $metric_description_ref, $metric_found_ref, 978 $user_metrics, $system_metrics, $wall_metrics, 979 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics 980 ) = process_metrics_data ($outfile1, $outfile2, \%ignored_metrics); 981 982 %metric_value = %{ $metric_value_ref }; 983 %metric_description = %{ $metric_description_ref }; 984 %metric_found = %{ $metric_found_ref }; 985 %metric_description_reversed = reverse %metric_description; 986 987 $msg = "after the call to process_metrics_data"; 988 gp_message ("debugXL", $subr_name, $msg); 989 990 for my $metric (sort keys %metric_value) 991 { 992 $msg = "metric_value{$metric} = " . $metric_value{$metric}; 993 gp_message ("debugXL", $subr_name, $msg); 994 } 995 for my $metric (sort keys %metric_description) 996 { 997 $msg = "metric_description{$metric} ="; 998 $msg .= " " . $metric_description{$metric}; 999 gp_message ("debugXL", $subr_name, $msg); 1000 } 1001 gp_message ("debugXL", $subr_name, "user_metrics = $user_metrics"); 1002 gp_message ("debugXL", $subr_name, "system_metrics = $system_metrics"); 1003 gp_message ("debugXL", $subr_name, "wall_metrics = $wall_metrics"); 1004 } 1005 else 1006 { 1007#------------------------------------------------------------------------------ 1008# A default set of metrics will be used. 1009# 1010# TBD: These should be OS dependent. 1011#------------------------------------------------------------------------------ 1012 $msg = "select the set of default metrics"; 1013 gp_message ("verbose", $subr_name, $msg); 1014 1015 ($metric_description_ref, $metric_found_ref, $summary_metrics, 1016 $detail_metrics, $detail_metrics_system, $call_metrics 1017 ) = set_default_metrics ($outfile1, \%ignored_metrics); 1018 1019 1020 %metric_description = %{ $metric_description_ref }; 1021 %metric_found = %{ $metric_found_ref }; 1022 %metric_description_reversed = reverse %metric_description; 1023 1024 $msg = "after the call to set_default_metrics"; 1025 gp_message ("debug", $subr_name, $msg); 1026 1027 } 1028 1029 $number_of_metrics = split (":", $summary_metrics); 1030 1031 $msg = "summary_metrics = " . $summary_metrics; 1032 gp_message ("debugXL", $subr_name, $msg); 1033 $msg = "detail_metrics = " . $detail_metrics; 1034 gp_message ("debugXL", $subr_name, $msg); 1035 $msg = "detail_metrics_system = " . $detail_metrics_system; 1036 gp_message ("debugXL", $subr_name, $msg); 1037 $msg = "call_metrics = " . $call_metrics; 1038 gp_message ("debugXL", $subr_name, $msg); 1039 $msg = "number_of_metrics = " . $number_of_metrics; 1040 gp_message ("debugXL", $subr_name, $msg); 1041 1042#------------------------------------------------------------------------------ 1043# TBD Find a way to better handle this situation: 1044#------------------------------------------------------------------------------ 1045 for my $im (keys %metric_found) 1046 { 1047 $msg = "metric_found{$im} = " . $metric_found{$im}; 1048 gp_message ("debugXL", $subr_name, $msg); 1049 } 1050 for my $im (keys %ignored_metrics) 1051 { 1052 if (not exists ($metric_found{$im})) 1053 { 1054 $msg = "user requested ignored metric (-im) $im does not exist in"; 1055 $msg .= " collected metrics"; 1056 gp_message ("debugXL", $subr_name, $msg); 1057 } 1058 } 1059 1060#------------------------------------------------------------------------------ 1061# Get the information on the experiments. 1062#------------------------------------------------------------------------------ 1063 $msg = "generate the experiment information"; 1064 gp_message ("verbose", $subr_name, $msg); 1065 1066 my $experiment_data_ref = get_experiment_info (\$outputdir, \@exp_dir_list); 1067 @experiment_data = @{ $experiment_data_ref }; 1068 1069 for my $i (sort keys @experiment_data) 1070 { 1071 my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " . 1072 $experiment_data[$i]{"exp_name_full"}; 1073 gp_message ("debugM", $subr_name, $msg); 1074 } 1075 1076 $experiment_data_ref = process_experiment_info ($experiment_data_ref); 1077 @experiment_data = @{ $experiment_data_ref }; 1078 1079 for my $i (sort keys @experiment_data) 1080 { 1081 for my $fields (sort keys %{ $experiment_data[$i] }) 1082 { 1083 my $msg = "i = $i experiment_data[$i]{$fields} = " . 1084 $experiment_data[$i]{$fields}; 1085 gp_message ("debugXL", $subr_name, $msg); 1086 } 1087 } 1088 1089 @g_html_experiment_stats = @{ create_exp_info (\@exp_dir_list, 1090 \@experiment_data) }; 1091 1092 $table_execution_stats_ref = html_generate_exp_summary (\$outputdir, 1093 \@experiment_data); 1094 @table_execution_stats = @{ $table_execution_stats_ref }; 1095 1096#------------------------------------------------------------------------------ 1097# Get the function overview. 1098#------------------------------------------------------------------------------ 1099 $msg = "generate the list with functions executed"; 1100 gp_message ("verbose", $subr_name, $msg); 1101 1102 my ($outfile, $sort_fields_ref) = 1103 get_hot_functions (\@exp_dir_list, $summary_metrics, $outputdir); 1104 1105 @sort_fields = @{$sort_fields_ref}; 1106 1107#------------------------------------------------------------------------------ 1108# Parse the output from the fsummary command and store the relevant data for 1109# all the functions listed there. 1110#------------------------------------------------------------------------------ 1111 $msg = "analyze and store the relevant function information"; 1112 gp_message ("verbose", $subr_name, $msg); 1113 1114 ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref, 1115 $LINUX_vDSO_ref, $function_view_structure_ref) = 1116 get_function_info ($outfile); 1117 1118 @function_info = @{ $function_info_ref }; 1119 %function_address_and_index = %{ $function_address_and_index_ref }; 1120 %addressobjtextm = %{ $addressobjtextm_ref }; 1121 %LINUX_vDSO = %{ $LINUX_vDSO_ref }; 1122 %function_view_structure = %{ $function_view_structure_ref }; 1123 1124 $msg = "found " . $g_total_function_count . " functions to process"; 1125 gp_message ("verbose", $subr_name, $msg); 1126 1127 for my $keys (0 .. $#function_info) 1128 { 1129 for my $fields (keys %{$function_info[$keys]}) 1130 { 1131 $msg = "$keys $fields $function_info[$keys]{$fields}"; 1132 gp_message ("debugXL", $subr_name, $msg); 1133 } 1134 } 1135 1136 for my $i (keys %addressobjtextm) 1137 { 1138 $msg = "addressobjtextm{$i} = " . $addressobjtextm{$i}; 1139 gp_message ("debugXL", $subr_name, $msg); 1140 } 1141 1142 $msg = "generate the files with function overviews and the"; 1143 $msg .= " callers-callees information"; 1144 gp_message ("verbose", $subr_name, $msg); 1145 1146 $script_pc_metrics = generate_function_level_info (\@exp_dir_list, 1147 $call_metrics, 1148 $summary_metrics, 1149 $outputdir, 1150 $sort_fields_ref); 1151 1152 $msg = "preprocess the files with the function level information"; 1153 gp_message ("verbose", $subr_name, $msg); 1154 1155 $ignore_value = preprocess_function_files ( 1156 $metric_description_ref, 1157 $script_pc_metrics, 1158 $outputdir, 1159 \@sort_fields); 1160 1161 $msg = "for each function, generate a set of files"; 1162 gp_message ("verbose", $subr_name, $msg); 1163 1164 ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) = 1165 process_function_files (\@exp_dir_list, 1166 $executable_name, 1167 $time_percentage_multiplier, 1168 $summary_metrics, 1169 $process_all_functions, 1170 $elf_loadobjects_found, 1171 $outputdir, 1172 \@sort_fields, 1173 \@function_info, 1174 \%function_address_and_index, 1175 \%LINUX_vDSO, 1176 \%metric_description, 1177 $elf_arch, 1178 $base_va_executable, 1179 $ARCHIVES_MAP_NAME, 1180 $ARCHIVES_MAP_VADDR, 1181 \%elf_rats); 1182 1183 @function_info = @{ $function_info_ref }; 1184 %function_address_info = %{ $function_address_info_ref }; 1185 %addressobj_index = %{ $addressobj_index_ref }; 1186 1187#------------------------------------------------------------------------------ 1188# Parse the disassembly information and generate the html files. 1189#------------------------------------------------------------------------------ 1190 $msg = "parse the disassembly files and generate the html files"; 1191 gp_message ("verbose", $subr_name, $msg); 1192 1193 $ignore_value = parse_dis_files (\$number_of_metrics, 1194 \@function_info, 1195 \%function_address_and_index, 1196 \$outputdir, 1197 \%addressobj_index); 1198 1199#------------------------------------------------------------------------------ 1200# Parse the source information and generate the html files. 1201#------------------------------------------------------------------------------ 1202 $msg = "parse the source files and generate the html files"; 1203 gp_message ("verbose", $subr_name, $msg); 1204 1205 parse_source_files (\$number_of_metrics, \@function_info, \$outputdir); 1206 1207#------------------------------------------------------------------------------ 1208# Parse the caller-callee information and generate the html files. 1209#------------------------------------------------------------------------------ 1210 $msg = "process the caller-callee information and generate the html file"; 1211 gp_message ("verbose", $subr_name, $msg); 1212 1213#------------------------------------------------------------------------------ 1214# Generate the caller-callee information. 1215#------------------------------------------------------------------------------ 1216 $ignore_value = generate_caller_callee (\$number_of_metrics, 1217 \@function_info, 1218 \%function_view_structure, 1219 \%function_address_info, 1220 \%addressobjtextm, 1221 \$outputdir); 1222 1223#------------------------------------------------------------------------------ 1224# Parse the calltree information and generate the html files. 1225#------------------------------------------------------------------------------ 1226 if ($g_user_settings{"calltree"}{"current_value"} eq "on") 1227 { 1228 $msg = "process the call tree information and generate the html file"; 1229 gp_message ("verbose", $subr_name, $msg); 1230 1231 $ignore_value = process_calltree (\@function_info, 1232 \%function_address_info, 1233 \%addressobjtextm, 1234 $outputdir); 1235 } 1236 1237#------------------------------------------------------------------------------ 1238# Process the metric values. 1239#------------------------------------------------------------------------------ 1240 $msg = "generate the html file with the metrics information"; 1241 gp_message ("verbose", $subr_name, $msg); 1242 1243 $ignore_value = process_metrics ($outputdir, 1244 \@sort_fields, 1245 \%metric_description, 1246 \%ignored_metrics); 1247 1248#------------------------------------------------------------------------------ 1249# Generate the function view html files. 1250#------------------------------------------------------------------------------ 1251 $msg = "generate the function view html files"; 1252 gp_message ("verbose", $subr_name, $msg); 1253 1254 $html_first_metric_file_ref = generate_function_view ( 1255 \$outputdir, 1256 \$summary_metrics, 1257 \$number_of_metrics, 1258 \@function_info, 1259 \%function_view_structure, 1260 \%function_address_info, 1261 \@sort_fields, 1262 \@exp_dir_list, 1263 \%addressobjtextm); 1264 1265 $html_first_metric_file = ${ $html_first_metric_file_ref }; 1266 1267 $msg = "html_first_metric_file = " . $html_first_metric_file; 1268 gp_message ("debugXL", $subr_name, $msg); 1269 1270 $html_test = ${ generate_home_link ("left") }; 1271 $msg = "html_test = " . $html_test; 1272 gp_message ("debugXL", $subr_name, $msg); 1273 1274#------------------------------------------------------------------------------ 1275# Unconditionnaly generate the page with the warnings. 1276#------------------------------------------------------------------------------ 1277 $ignore_value = html_create_warnings_page (\$outputdir); 1278 1279#------------------------------------------------------------------------------ 1280# Generate the index.html file. 1281#------------------------------------------------------------------------------ 1282 $msg = "generate the index.html file"; 1283 gp_message ("verbose", $subr_name, $msg); 1284 1285 $ignore_value = html_generate_index (\$outputdir, 1286 \$html_first_metric_file, 1287 \$summary_metrics, 1288 \$number_of_metrics, 1289 \@function_info, 1290 \%function_address_info, 1291 \@sort_fields, 1292 \@exp_dir_list, 1293 \%addressobjtextm, 1294 \%metric_description_reversed, 1295 \@table_execution_stats); 1296 1297#------------------------------------------------------------------------------ 1298# We're done. In debug mode, print the meta data for the experiment 1299# directories. 1300#------------------------------------------------------------------------------ 1301 $ignore_value = print_meta_data_experiments ("debug"); 1302 1303#------------------------------------------------------------------------------ 1304# Before the execution completes, print the warning(s) on the screen. 1305# 1306# Note that this assumes that no additional warnings have been created since 1307# the call to html_create_warnings_page. Otherwise there will be a discrepancy 1308# between what is printed on the screen and shown in the warnings.html page. 1309#------------------------------------------------------------------------------ 1310 if (($g_total_warning_count > 0) and ($g_warnings)) 1311 { 1312 $ignore_value = print_warnings_buffer (); 1313 @g_warning_msgs = (); 1314 } 1315 1316#------------------------------------------------------------------------------ 1317# This is not supposed to happen, but in case there are any fatal errors that 1318# have not caused the execution to terminate, print them here. 1319#------------------------------------------------------------------------------ 1320 if (@g_error_msgs) 1321 { 1322 $ignore_value = print_errors_buffer (\$g_error_keyword); 1323 } 1324 1325#------------------------------------------------------------------------------ 1326# One line message to show where the results can be found. 1327#------------------------------------------------------------------------------ 1328 my $results_file = $abs_path_outputdir . "/index.html"; 1329 my $prologue_text = "Processing completed - view file $results_file" . 1330 " in a browser"; 1331 gp_message ("diag", $subr_name, $prologue_text); 1332 1333 return (0); 1334 1335} #-- End of subroutine main 1336 1337#------------------------------------------------------------------------------ 1338# If it is not present, add a "/" to the name of the argument. This is 1339# intended to be used for the name of the output directory and makes it 1340# easier to construct pathnames. 1341#------------------------------------------------------------------------------ 1342sub append_forward_slash 1343{ 1344 my $subr_name = get_my_name (); 1345 1346 my ($input_string) = @_; 1347 1348 my $length_of_string = length ($input_string); 1349 my $return_string = $input_string; 1350 1351 if (rindex ($input_string, "/") != $length_of_string-1) 1352 { 1353 $return_string .= "/"; 1354 } 1355 1356 return ($return_string); 1357 1358} #-- End of subroutine append_forward_slash 1359 1360#------------------------------------------------------------------------------ 1361# Return a string with a comma separated list of directory names. 1362#------------------------------------------------------------------------------ 1363sub build_pretty_dir_list 1364{ 1365 my $subr_name = get_my_name (); 1366 1367 my ($dir_list_ref) = @_; 1368 1369 my @dir_list = @{ $dir_list_ref}; 1370 1371 my $pretty_dir_list = join ("\n", @dir_list); 1372 1373 return ($pretty_dir_list); 1374 1375} #-- End of subroutine build_pretty_dir_list 1376 1377#------------------------------------------------------------------------------ 1378# Calculate the target address in hex by adding the instruction to the 1379# instruction address. 1380#------------------------------------------------------------------------------ 1381sub calculate_target_hex_address 1382{ 1383 my $subr_name = get_my_name (); 1384 1385 my ($instruction_address, $instruction_offset) = @_; 1386 1387 my $dec_branch_target; 1388 my $d1; 1389 my $d2; 1390 my $first_char; 1391 my $length_of_string; 1392 my $mask; 1393 my $msg; 1394 my $number_of_fields; 1395 my $raw_hex_branch_target; 1396 my $result; 1397 1398 if ($g_addressing_mode eq "64 bit") 1399 { 1400 $mask = "0xffffffffffffffff"; 1401 $number_of_fields = 16; 1402 } 1403 else 1404 { 1405 $msg = "g_addressing_mode = $g_addressing_mode not supported"; 1406 gp_message ("abort", $subr_name, $msg); 1407 } 1408 1409 $length_of_string = length ($instruction_offset); 1410 $first_char = lcfirst (substr ($instruction_offset,0,1)); 1411 $d1 = bigint::hex ($instruction_offset); 1412 $d2 = bigint::hex ($mask); 1413# if ($first_char eq "f") 1414 if (($first_char =~ /[89a-f]/) and ($length_of_string == $number_of_fields)) 1415 { 1416#------------------------------------------------------------------------------ 1417# The offset is negative. Convert to decimal and perform the subtrraction. 1418#------------------------------------------------------------------------------ 1419#------------------------------------------------------------------------------ 1420# XOR the decimal representation and add 1 to the result. 1421#------------------------------------------------------------------------------ 1422 $result = ($d1 ^ $d2) + 1; 1423 $dec_branch_target = bigint::hex ($instruction_address) - $result; 1424 } 1425 else 1426 { 1427 $result = $d1; 1428 $dec_branch_target = bigint::hex ($instruction_address) + $result; 1429 } 1430#------------------------------------------------------------------------------ 1431# Convert to hexadecimal. 1432#------------------------------------------------------------------------------ 1433 $raw_hex_branch_target = sprintf ("%x", $dec_branch_target); 1434 1435 return ($raw_hex_branch_target); 1436 1437} #-- End of subroutine calculate_target_hex_address 1438 1439#------------------------------------------------------------------------------ 1440# Sets the absolute path to all commands in array @cmds. 1441# 1442# First, it is checked if the command is in the search path, built-in, or an 1443# alias. If this is not the case, search for it in a couple of locations. 1444# 1445# If this all fails, warning messages are printed, but this is not a hard 1446# error. Yet. Most likely, things will go bad later on. 1447# 1448# The commands and their respective paths are stored in hash "g_mapped_cmds". 1449#------------------------------------------------------------------------------ 1450sub check_and_define_cmds 1451{ 1452 my $subr_name = get_my_name (); 1453 1454 my ($cmds_ref, $search_path_ref) = @_; 1455 1456#------------------------------------------------------------------------------ 1457# Dereference the array addressess first and then store the contents. 1458#------------------------------------------------------------------------------ 1459 my @cmds = @{$cmds_ref}; 1460 my @search_path = @{$search_path_ref}; 1461 1462 my @the_fields = (); 1463 1464 my $cmd; 1465 my $cmd_found; 1466 my $error_code; 1467 my $failed_cmd; 1468 my $failed_cmds; 1469 my $found_match; 1470 my $mapped; 1471 my $msg; 1472 my $no_of_failed_mappings; 1473 my $no_of_fields; 1474 my $output_cmd; 1475 my $target_cmd; 1476 my $failed_mapping = $FALSE; 1477 my $full_path_cmd; 1478 1479 gp_message ("debugXL", $subr_name, "\@cmds = @cmds"); 1480 gp_message ("debugXL", $subr_name, "\@search_path = @search_path"); 1481 1482#------------------------------------------------------------------------------ 1483# Search for the command and record the absolute path. In case no such path 1484# can be found, the entry in $g_mapped_cmds is assigned a special value that 1485# will be checked for in the next block. 1486#------------------------------------------------------------------------------ 1487 for $cmd (@cmds) 1488 { 1489 $target_cmd = "(command -v $cmd; echo \$\?)"; 1490 1491 ($error_code, $output_cmd) = execute_system_cmd ($target_cmd); 1492 1493 if ($error_code != 0) 1494#------------------------------------------------------------------------------ 1495# This is unlikely to happen, since it means the command executed failed. 1496#------------------------------------------------------------------------------ 1497 { 1498 $msg = "error executing this command: " . $target_cmd; 1499 gp_message ("warning", $subr_name, $msg); 1500 $msg = "execution continues, but may fail later on"; 1501 gp_message ("warning", $subr_name, $msg); 1502 1503 $g_total_warning_count++; 1504 } 1505 else 1506#------------------------------------------------------------------------------ 1507# So far, all is well, but is the target command available? 1508#------------------------------------------------------------------------------ 1509 { 1510#------------------------------------------------------------------------------ 1511# The output from the $target_cmd command should contain 2 lines in case the 1512# command has been found. The first line shows the command with the full 1513# path, while the second line has the exit code. 1514# 1515# If the exit code is not zero, the command has not been found. 1516#------------------------------------------------------------------------------ 1517 1518#------------------------------------------------------------------------------ 1519# Split the output at the \n character and check the number of lines as 1520# well as the return code. 1521#------------------------------------------------------------------------------ 1522 @the_fields = split ("\n", $output_cmd); 1523 $no_of_fields = scalar (@the_fields); 1524 $cmd_found = ($the_fields[$no_of_fields-1] == 0 ? $TRUE : $FALSE); 1525 1526#------------------------------------------------------------------------------ 1527# This is unexpected. Throw an assertion error and bail out. 1528#------------------------------------------------------------------------------ 1529 if ($no_of_fields > 2) 1530 { 1531 gp_message ("error", $subr_name, "output from $target_cmd:"); 1532 gp_message ("error", $subr_name, $output_cmd); 1533 1534 $msg = "the output from $target_cmd has more than 2 lines"; 1535 gp_message ("assertion", $subr_name, $msg); 1536 } 1537 1538 if ($cmd_found) 1539 { 1540 $full_path_cmd = $the_fields[0]; 1541#------------------------------------------------------------------------------ 1542# The command is in the search path. Store the full path to the command. 1543#------------------------------------------------------------------------------ 1544 $msg = "the $cmd command is in the search path"; 1545 gp_message ("debug", $subr_name, $msg); 1546 1547 $g_mapped_cmds{$cmd} = $full_path_cmd; 1548 } 1549 else 1550#------------------------------------------------------------------------------ 1551# A best effort to locate the command elsewhere. If found, store the command 1552# with the absolute path included. Otherwise print a warning, but continue. 1553#------------------------------------------------------------------------------ 1554 { 1555 $msg = "the $cmd command is not in the search path"; 1556 $msg .= " - start a best effort search to find it"; 1557 gp_message ("debug", $subr_name, $msg); 1558 1559 $found_match = $FALSE; 1560 for my $path (@search_path) 1561 { 1562 $target_cmd = $path . "/" . $cmd; 1563 if (-x $target_cmd) 1564 { 1565 $msg = "found the command in $path"; 1566 gp_message ("debug", $subr_name, $msg); 1567 1568 $found_match = $TRUE; 1569 $g_mapped_cmds{$cmd} = $target_cmd; 1570 last; 1571 } 1572 else 1573 { 1574 $msg = "failure to find the $cmd command in $path"; 1575 gp_message ("debug", $subr_name, $msg); 1576 } 1577 } 1578 1579 if (not $found_match) 1580 { 1581 $g_mapped_cmds{$cmd} = "road to nowhere"; 1582 $failed_mapping = $TRUE; 1583 } 1584 } 1585 } 1586 } 1587 1588#------------------------------------------------------------------------------ 1589# Scan the results stored in $g_mapped_cmds and flag errors. 1590#------------------------------------------------------------------------------ 1591 $no_of_failed_mappings = 0; 1592 $failed_cmds = ""; 1593 1594#------------------------------------------------------------------------------ 1595# Print a warning message before showing the results, that at least one search 1596# has failed. 1597#------------------------------------------------------------------------------ 1598 if ($failed_mapping) 1599 { 1600 $msg = "<br>" . "failure in the verification of the OS commands:"; 1601 gp_message ("warning", $subr_name, $msg); 1602 } 1603 1604 while ( ($cmd, $mapped) = each %g_mapped_cmds) 1605 { 1606 if ($mapped eq "road to nowhere") 1607 { 1608 $msg = "cannot find a path for command $cmd"; 1609 gp_message ("warning", $subr_name, $msg); 1610 gp_message ("debug", $subr_name, $msg); 1611 1612 $no_of_failed_mappings++; 1613 $failed_cmds .= $cmd; 1614 $g_mapped_cmds{$cmd} = $cmd; 1615 } 1616 else 1617 { 1618 $msg = "path for the $cmd command is $mapped"; 1619 gp_message ("debug", $subr_name, $msg); 1620 } 1621 } 1622 if ($no_of_failed_mappings != 0) 1623 { 1624 my $plural_1 = ($no_of_failed_mappings > 1) ? "failures" : "failure"; 1625 my $plural_2 = ($no_of_failed_mappings > 1) ? "commands" : "command"; 1626 1627 $msg = "encountered $no_of_failed_mappings $plural_1 to locate"; 1628 $msg .= " selected " . $plural_2; 1629 gp_message ("warning", $subr_name, $msg); 1630 gp_message ("debug", $subr_name, $msg); 1631 1632 $msg = "execution continues, but may fail later on"; 1633 gp_message ("warning", $subr_name, $msg); 1634 gp_message ("debug", $subr_name, $msg); 1635 1636 $g_total_warning_count++; 1637 } 1638 1639 return ($no_of_failed_mappings); 1640 1641} #-- End of subroutine check_and_define_cmds 1642 1643#------------------------------------------------------------------------------ 1644# Look for a branch instruction, or the special endbr32/endbr64 instruction 1645# that is also considered to be a branch target. Note that the latter is x86 1646# specific. 1647#------------------------------------------------------------------------------ 1648sub check_and_proc_dis_branches 1649{ 1650 my $subr_name = get_my_name (); 1651 1652 my ($input_line_ref, $line_no_ref, $branch_target_ref, 1653 $extended_branch_target_ref, $branch_target_no_ref_ref) = @_; 1654 1655 my $input_line = ${ $input_line_ref }; 1656 my $line_no = ${ $line_no_ref }; 1657 my %branch_target = %{ $branch_target_ref }; 1658 my %extended_branch_target = %{ $extended_branch_target_ref }; 1659 my %branch_target_no_ref = %{ $branch_target_no_ref_ref }; 1660 1661 my $found_it = $TRUE; 1662 my $hex_branch_target; 1663 my $instruction_address; 1664 my $instruction_offset; 1665 my $msg; 1666 my $raw_hex_branch_target; 1667 1668 if ( ($input_line =~ /$g_branch_regex/) 1669 or ($input_line =~ /$g_endbr_regex/)) 1670 { 1671 if (defined ($3)) 1672 { 1673 $msg = "found a branch or endbr instruction: " . 1674 "\$1 = $1 \$2 = $2 \$3 = $3"; 1675 } 1676 else 1677 { 1678 $msg = "found a branch or endbr instruction: " . 1679 "\$1 = $1 \$2 = $2"; 1680 } 1681 gp_message ("debugXL", $subr_name, $msg); 1682 1683 if (defined ($1)) 1684 { 1685#------------------------------------------------------------------------------ 1686# Found a qualifying instruction 1687#------------------------------------------------------------------------------ 1688 $instruction_address = $1; 1689 if (defined ($3)) 1690 { 1691#------------------------------------------------------------------------------ 1692# This must be the branch target and needs to be converted and processed. 1693#------------------------------------------------------------------------------ 1694 $instruction_offset = $3; 1695 $raw_hex_branch_target = calculate_target_hex_address ( 1696 $instruction_address, 1697 $instruction_offset); 1698 1699 $hex_branch_target = "0x" . $raw_hex_branch_target; 1700 $branch_target{$hex_branch_target} = 1; 1701 $extended_branch_target{$instruction_address} = 1702 $raw_hex_branch_target; 1703 } 1704 if (defined ($2) and (not defined ($3))) 1705 { 1706#------------------------------------------------------------------------------ 1707# Unlike a branch, the endbr32/endbr64 instructions do not have a second field. 1708#------------------------------------------------------------------------------ 1709 my $instruction_name = $2; 1710 if ($instruction_name =~ /$g_endbr_inst_regex/) 1711 { 1712 my $msg = "found endbr: $instruction_name " . 1713 $instruction_address; 1714 gp_message ("debugXL", $subr_name, $msg); 1715 $raw_hex_branch_target = $instruction_address; 1716 1717 $hex_branch_target = "0x" . $raw_hex_branch_target; 1718 $branch_target_no_ref{$instruction_address} = 1; 1719 } 1720 } 1721 } 1722 else 1723 { 1724#------------------------------------------------------------------------------ 1725# TBD: Perhaps this should be an assertion or alike. 1726#------------------------------------------------------------------------------ 1727 $branch_target{"0x0000"} = $FALSE; 1728 $msg = "cannot determine branch target"; 1729 gp_message ("debug", $subr_name, $msg); 1730 } 1731 } 1732 else 1733 { 1734 $found_it = $FALSE; 1735 } 1736 1737 return (\$found_it, \%branch_target, \%extended_branch_target, 1738 \%branch_target_no_ref); 1739 1740} #-- End of subroutine check_and_proc_dis_branches 1741 1742#------------------------------------------------------------------------------ 1743# Check an input line from the disassembly file to include a function call. 1744# If it does, process the line and return the branch target results. 1745#------------------------------------------------------------------------------ 1746sub check_and_proc_dis_func_call 1747{ 1748 my $subr_name = get_my_name (); 1749 1750 my ($input_line_ref, $line_no_ref, $branch_target_ref, 1751 $extended_branch_target_ref) = @_; 1752 1753 my $input_line = ${ $input_line_ref }; 1754 my $line_no = ${ $line_no_ref }; 1755 my %branch_target = %{ $branch_target_ref }; 1756 my %extended_branch_target = %{ $extended_branch_target_ref }; 1757 1758 my $found_it = $TRUE; 1759 my $hex_branch_target; 1760 my $instruction_address; 1761 my $instruction_offset; 1762 my $msg; 1763 my $raw_hex_branch_target; 1764 1765 if ( $input_line =~ /$g_function_call_v2_regex/ ) 1766 { 1767 $msg = "found a function call - line[$line_no] = $input_line"; 1768 gp_message ("debugXL", $subr_name, $msg); 1769 if (not defined ($2)) 1770 { 1771 $msg = "line[$line_no] " . 1772 "an instruction address is expected, but not found"; 1773 gp_message ("assertion", $subr_name, $msg); 1774 } 1775 else 1776 { 1777 $instruction_address = $2; 1778 1779 $msg = "instruction_address = $instruction_address"; 1780 gp_message ("debugXL", $subr_name, $msg); 1781 1782 if (not defined ($4)) 1783 { 1784 $msg = "line[$line_no] " . 1785 "an address offset is expected, but not found"; 1786 gp_message ("assertion", $subr_name, $msg); 1787 } 1788 else 1789 { 1790 $instruction_offset = $4; 1791 if ($instruction_offset =~ /[0-9a-fA-F]+/) 1792 { 1793 $msg = "calculate branch target: " . 1794 "instruction_address = $instruction_address"; 1795 gp_message ("debugXL", $subr_name, $msg); 1796 $msg = "calculate branch target: " . 1797 "instruction_offset = $instruction_offset"; 1798 gp_message ("debugXL", $subr_name, $msg); 1799 1800#------------------------------------------------------------------------------ 1801# The instruction offset needs to be converted and added to the instruction 1802# address. 1803#------------------------------------------------------------------------------ 1804 $raw_hex_branch_target = calculate_target_hex_address ( 1805 $instruction_address, 1806 $instruction_offset); 1807 $hex_branch_target = "0x" . $raw_hex_branch_target; 1808 1809 $msg = "calculated hex_branch_target = " . 1810 $hex_branch_target; 1811 gp_message ("debugXL", $subr_name, $msg); 1812 1813 $branch_target{$hex_branch_target} = 1; 1814 $extended_branch_target{$instruction_address} = 1815 $raw_hex_branch_target; 1816 1817 $msg = "set branch_target{$hex_branch_target} to 1"; 1818 gp_message ("debugXL", $subr_name, $msg); 1819 $msg = "added extended_branch_target{$instruction_address}"; 1820 $msg .= " = $extended_branch_target{$instruction_address}"; 1821 gp_message ("debugXL", $subr_name, $msg); 1822 } 1823 else 1824 { 1825 $msg = "line[$line_no] unknown address format"; 1826 gp_message ("assertion", $subr_name, $msg); 1827 } 1828 } 1829 } 1830 } 1831 else 1832 { 1833 $found_it = $FALSE; 1834 } 1835 1836 return (\$found_it, \%branch_target, \%extended_branch_target); 1837 1838} #-- End of subroutine check_and_proc_dis_func_call 1839 1840#------------------------------------------------------------------------------ 1841# Check if the value for the user option given is valid. 1842# 1843# In case the value is valid, the g_user_settings table is updated with the 1844# (new) value. 1845# 1846# Otherwise an error message is pushed into the g_error_msgs buffer. 1847# 1848# The return value is TRUE/FALSE. 1849#------------------------------------------------------------------------------ 1850sub check_and_set_user_option 1851{ 1852 my $subr_name = get_my_name (); 1853 1854 my ($internal_opt_name, $value) = @_; 1855 1856 my $msg; 1857 my $valid; 1858 my $option_value_missing; 1859 1860 my $option = $g_user_settings{$internal_opt_name}{"option"}; 1861 my $data_type = $g_user_settings{$internal_opt_name}{"data_type"}; 1862 my $no_of_args = $g_user_settings{$internal_opt_name}{"no_of_arguments"}; 1863 1864 if (($no_of_args >= 1) and 1865 ((not defined ($value)) or (length ($value) == 0))) 1866#------------------------------------------------------------------------------ 1867# If there was no value given, but it is required, flag an error. 1868# There could also be a value, but it might be the empty string. 1869# 1870# Note that that there are currently no options with multiple values. Should 1871# these be introduced, the current check may need to be refined. 1872#------------------------------------------------------------------------------ 1873 { 1874 $valid = $FALSE; 1875 $option_value_missing = $TRUE; 1876 } 1877 elsif ($no_of_args >= 1) 1878 { 1879 $option_value_missing = $FALSE; 1880#------------------------------------------------------------------------------ 1881# There is an input value. Check if it is valid and if so, store it. 1882# 1883# Note that we allow the options to be case insensitive. 1884#------------------------------------------------------------------------------ 1885 $valid = verify_if_input_is_valid ($value, $data_type); 1886 1887 if ($valid) 1888 { 1889 if (($data_type eq "onoff") or ($data_type eq "size")) 1890 { 1891 $g_user_settings{$internal_opt_name}{"current_value"} = 1892 lc ($value); 1893 } 1894 else 1895 { 1896 $g_user_settings{$internal_opt_name}{"current_value"} = $value; 1897 } 1898 $g_user_settings{$internal_opt_name}{"defined"} = $TRUE; 1899 } 1900 } 1901 1902 return (\$valid, \$option_value_missing); 1903 1904} #-- End of subroutine check_and_set_user_option 1905 1906#------------------------------------------------------------------------------ 1907# Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool 1908# needed to provide the information. If it can not be found, execution is 1909# terminated. 1910# 1911# We first search for this tool in the current execution directory. If it 1912# cannot be found there, use $PATH to try to locate it. 1913#------------------------------------------------------------------------------ 1914sub check_availability_tool 1915{ 1916 my $subr_name = get_my_name (); 1917 1918 my ($location_gp_command_ref) = @_; 1919 1920 my $error_code; 1921 my $error_occurred; 1922 my $gp_path; 1923 my $msg; 1924 my $output_which_gp_display_text; 1925 my $return_value; 1926 my $target_cmd; 1927 1928#------------------------------------------------------------------------------ 1929# Get the path to gp-display-text. 1930#------------------------------------------------------------------------------ 1931 my ($error_occurred_ref, $gp_path_ref, $return_value_ref) = 1932 find_path_to_gp_display_text ($location_gp_command_ref); 1933 1934 $error_occurred = ${ $error_occurred_ref}; 1935 $gp_path = ${ $gp_path_ref }; 1936 $return_value = ${ $return_value_ref}; 1937 1938 $msg = "error_occurred = $error_occurred return_value = $return_value"; 1939 gp_message ("debugXL", $subr_name, $msg); 1940 1941 if (not $error_occurred) 1942#------------------------------------------------------------------------------ 1943# All is well and gp-display-text has been located. 1944#------------------------------------------------------------------------------ 1945 { 1946 $g_path_to_tools = $return_value; 1947 1948 $msg = "located $GP_DISPLAY_TEXT in the execution directory"; 1949 gp_message ("debug", $subr_name, $msg); 1950 $msg = "g_path_to_tools = $g_path_to_tools"; 1951 gp_message ("debug", $subr_name, $msg); 1952 } 1953 else 1954#------------------------------------------------------------------------------ 1955# Something went wrong, but perhaps we can still continue. Try to find 1956# $GP_DISPLAY_TEXT through the search path. 1957#------------------------------------------------------------------------------ 1958 { 1959 $msg = $g_html_new_line; 1960 $msg .= "could not find $GP_DISPLAY_TEXT in directory $gp_path :"; 1961 $msg .= " $return_value"; 1962 gp_message ("warning", $subr_name, $msg); 1963 1964#------------------------------------------------------------------------------ 1965# Check if we can find $GP_DISPLAY_TEXT in the search path. 1966#------------------------------------------------------------------------------ 1967 $msg = "check for $GP_DISPLAY_TEXT to be in the search path"; 1968 gp_message ("debug", $subr_name, $msg); 1969 1970 gp_message ("warning", $subr_name, $msg); 1971 $g_total_warning_count++; 1972 1973 $target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1"; 1974 1975 ($error_code, $output_which_gp_display_text) = 1976 execute_system_cmd ($target_cmd); 1977 1978 if ($error_code == 0) 1979 { 1980 my ($gp_file_name, $gp_path, $suffix_not_used) = 1981 fileparse ($output_which_gp_display_text); 1982 $g_path_to_tools = $gp_path; 1983 1984 $msg = "located $GP_DISPLAY_TEXT in $g_path_to_tools"; 1985 gp_message ("warning", $subr_name, $msg); 1986 $msg = "this is the version that will be used"; 1987 gp_message ("warning", $subr_name, $msg); 1988 1989 $msg = "the $GP_DISPLAY_TEXT tool is in the search path"; 1990 gp_message ("debug", $subr_name, $msg); 1991 $msg = "g_path_to_tools = $g_path_to_tools"; 1992 gp_message ("debug", $subr_name, $msg); 1993 } 1994 else 1995 { 1996 $msg = "failure to find $GP_DISPLAY_TEXT in the search path"; 1997 gp_message ("error", $subr_name, $msg); 1998 1999 $g_total_error_count++; 2000 2001 gp_message ("abort", $subr_name, $g_abort_msg); 2002 } 2003 } 2004 2005 return (\$g_path_to_tools); 2006 2007} #-- End of subroutine check_availability_tool 2008 2009#------------------------------------------------------------------------------ 2010# This function determines whether load objects are in ELF format. 2011# 2012# Compared to the original code, any input value other than 2 or 3 is rejected 2013# upfront. This not only reduces the nesting level, but also eliminates a 2014# possible bug. 2015# 2016# Also, by isolating the tests for the input files, another nesting level could 2017# be eliminated, further simplifying this still too complex code. 2018#------------------------------------------------------------------------------ 2019sub check_loadobjects_are_elf 2020{ 2021 my $subr_name = get_my_name (); 2022 2023 my ($selected_archive) = @_; 2024 2025 my $event_kind_map_regex; 2026 $event_kind_map_regex = '^<event kind="map"\s.*vaddr='; 2027 $event_kind_map_regex .= '"0x([0-9a-fA-F]+)"\s+.*foffset='; 2028 $event_kind_map_regex .= '"\+*0x([0-9a-fA-F]+)"\s.*modes='; 2029 $event_kind_map_regex .= '"0x([0-9]+)"\s.*name="(.*)".*>$'; 2030 2031 my $hostname_current = $local_system_config{"hostname_current"}; 2032 my $arch = $local_system_config{"processor"}; 2033 my $arch_uname_s = $local_system_config{"kernel_name"}; 2034 2035 my $extracted_information; 2036 2037 my $elf_magic_number; 2038 2039 my $executable_name; 2040 my $va_executable_in_hex; 2041 2042 my $arch_exp; 2043 my $hostname_exp; 2044 my $os_exp; 2045 my $os_exp_full; 2046 2047 my $archives_file; 2048 my $rc_b; 2049 my $file; 2050 my $line; 2051 my $msg; 2052 my $name; 2053 my $name_path; 2054 my $foffset; 2055 my $vaddr; 2056 my $modes; 2057 2058 my $path_to_map_file; 2059 my $path_to_log_file; 2060 2061#------------------------------------------------------------------------------ 2062# TBD: Parameterize and should be the first experiment directory from the list. 2063#------------------------------------------------------------------------------ 2064 $path_to_log_file = 2065 $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; 2066 $path_to_log_file .= $selected_archive; 2067 $path_to_log_file .= "/log.xml"; 2068 2069 gp_message ("debug", $subr_name, "hostname_current = $hostname_current"); 2070 gp_message ("debug", $subr_name, "arch = $arch"); 2071 gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s"); 2072 2073#------------------------------------------------------------------------------ 2074# TBD 2075# 2076# This check can probably be removed since the presence of the log.xml file is 2077# checked for in an earlier phase. 2078#------------------------------------------------------------------------------ 2079 $msg = " - unable to open file $path_to_log_file for reading:"; 2080 open (LOG_XML, "<", $path_to_log_file) 2081 or die ($subr_name . $msg . " " . $!); 2082 2083 $msg = "opened file $path_to_log_file for reading"; 2084 gp_message ("debug", $subr_name, $msg); 2085 2086 while (<LOG_XML>) 2087 { 2088 $line = $_; 2089 chomp ($line); 2090 gp_message ("debugM", $subr_name, "read line: $line"); 2091#------------------------------------------------------------------------------ 2092# Search for the first line starting with "<system". Bail out if found and 2093# parsed. These are two examples: 2094# <system hostname="ruud-vm" arch="x86_64" \ 2095# os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514"> 2096#------------------------------------------------------------------------------ 2097 if ($line =~ /^\s*<system\s+/) 2098 { 2099 $msg = "selected the following line from the log.xml file:"; 2100 gp_message ("debugM", $subr_name, $msg); 2101 gp_message ("debugM", $subr_name, "$line"); 2102 if ($line =~ /.*\s+hostname="([^"]+)/) 2103 { 2104 $hostname_exp = $1; 2105 $msg = "extracted hostname_exp = " . $hostname_exp; 2106 gp_message ("debugM", $subr_name, $msg); 2107 } 2108 if ($line =~ /.*\s+arch="([^"]+)/) 2109 { 2110 $arch_exp = $1; 2111 $msg = "extracted arch_exp = " . $arch_exp; 2112 gp_message ("debugM", $subr_name, $msg); 2113 } 2114 if ($line =~ /.*\s+os="([^"]+)/) 2115 { 2116 $os_exp_full = $1; 2117#------------------------------------------------------------------------------ 2118# Capture the first word only. 2119#------------------------------------------------------------------------------ 2120 if ($os_exp_full =~ /([^\s]+)/) 2121 { 2122 $os_exp = $1; 2123 } 2124 $msg = "extracted os_exp = " . $os_exp; 2125 gp_message ("debugM", $subr_name, $msg); 2126 } 2127 last; 2128 } 2129 } #-- End of while loop 2130 2131 close (LOG_XML); 2132 2133#------------------------------------------------------------------------------ 2134# If the current system is identical to the system used in the experiment, 2135# we can return early. Otherwise we need to dig deeper. 2136# 2137# TBD: How about the other experiment directories?! This needs to be fixed. 2138#------------------------------------------------------------------------------ 2139 2140 gp_message ("debug", $subr_name, "completed while loop"); 2141 gp_message ("debug", $subr_name, "hostname_exp = $hostname_exp"); 2142 gp_message ("debug", $subr_name, "arch_exp = $arch_exp"); 2143 gp_message ("debug", $subr_name, "os_exp = $os_exp"); 2144 2145#TBD: THIS DOES NOT CHECK IF ELF IS FOUND! 2146 2147 if (($hostname_current eq $hostname_exp) and 2148 ($arch eq $arch_exp) and 2149 ($arch_uname_s eq $os_exp)) 2150 { 2151 $msg = "early return: the hostname, architecture and OS match"; 2152 $msg .= " the current system"; 2153 gp_message ("debug", $subr_name, $msg); 2154 $msg = "FAKE THIS IS NOT THE CASE AND CONTINUE"; 2155 gp_message ("debug", $subr_name, $msg); 2156# FAKE return ($TRUE); 2157 } 2158 2159 if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"}) 2160 { 2161 $msg = "selected_archive = " . $selected_archive; 2162 gp_message ("debug", $subr_name, $msg); 2163 for my $i (sort keys 2164 %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}}) 2165 { 2166 $msg = "stored loadobject " . $i . " "; 2167 $msg .= $g_exp_dir_meta_data{$selected_archive}{"archive_files"}{$i}; 2168 gp_message ("debug", $subr_name, $msg); 2169 } 2170 } 2171 2172#------------------------------------------------------------------------------ 2173# Check if the selected experiment directory has archived files in ELF format. 2174# If not, use the information in map.xml to get the name of the executable 2175# and the virtual address. 2176#------------------------------------------------------------------------------ 2177 2178 if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"}) 2179 { 2180 $msg = "the files in directory $selected_archive/archives are in"; 2181 $msg .= " ELF format"; 2182 gp_message ("debugM", $subr_name, $msg); 2183 $msg = "IGNORE THIS AND USE MAP.XML"; 2184 gp_message ("debugM", $subr_name, $msg); 2185## return ($TRUE); 2186 } 2187 2188 $msg = "the files in directory $selected_archive/archives are not in"; 2189 $msg .= " ELF format"; 2190 gp_message ("debug", $subr_name, $msg); 2191 2192 $path_to_map_file = 2193 $g_exp_dir_meta_data{$selected_archive}{"directory_path"}; 2194 $path_to_map_file .= $selected_archive; 2195 $path_to_map_file .= "/map.xml"; 2196 2197 $msg = " - unable to open file $path_to_map_file for reading:"; 2198 open (MAP_XML, "<", $path_to_map_file) 2199 or die ($subr_name . $msg . " " . $!); 2200 $msg = "opened file $path_to_map_file for reading"; 2201 gp_message ("debug", $subr_name, $msg); 2202 2203#------------------------------------------------------------------------------ 2204# Scan the map.xml file. We need to find the name of the executable with the 2205# mode set to 0x005. For this entry we have to capture the virtual address. 2206#------------------------------------------------------------------------------ 2207 $extracted_information = $FALSE; 2208 while (<MAP_XML>) 2209 { 2210 $line = $_; 2211 chomp ($line); 2212 gp_message ("debugM", $subr_name, "MAP_XML read line = $line"); 2213#------------------------------------------------------------------------------ 2214# Replaces this way too long line: 2215# if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+. 2216# *foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.* 2217# name="(.*)".*>$/) 2218#------------------------------------------------------------------------------ 2219 if ($line =~ /$event_kind_map_regex/) 2220 { 2221 gp_message ("debugM", $subr_name, "target line = $line"); 2222 $vaddr = $1; 2223 $foffset = $2; 2224 $modes = $3; 2225 $name_path = $4; 2226 $name = get_basename ($name_path); 2227 $msg = "extracted vaddr = $vaddr foffset = $foffset"; 2228 $msg .= " modes = $modes"; 2229 gp_message ("debugM", $subr_name, $msg); 2230 $msg = "extracted name_path = $name_path name = $name"; 2231 gp_message ("debugM", $subr_name, $msg); 2232# $error_extracting_information = $TRUE; 2233 $executable_name = $name; 2234 my $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); 2235 my $hex_VA = sprintf ("0x%016x", $result_VA); 2236 $va_executable_in_hex = $hex_VA; 2237 2238 $msg = "set executable_name = " . $executable_name; 2239 gp_message ("debugM", $subr_name, $msg); 2240 $msg = "set va_executable_in_hex = " . $va_executable_in_hex; 2241 gp_message ("debugM", $subr_name, $msg); 2242 $msg = "result_VA = " . $result_VA; 2243 gp_message ("debugM", $subr_name, $msg); 2244 $msg = "hex_VA = " . $hex_VA; 2245 gp_message ("debugM", $subr_name, $msg); 2246 2247 if ($modes eq "005") 2248 { 2249 $extracted_information = $TRUE; 2250 last; 2251 } 2252 } 2253 } 2254 2255 close (MAP_XML); 2256 2257 if (not $extracted_information) 2258 { 2259 $msg = "cannot find the necessary information in"; 2260 $msg .= " the $path_to_map_file file"; 2261 gp_message ("assertion", $subr_name, $msg); 2262 } 2263 2264## $executable_name = $ARCHIVES_MAP_NAME; 2265## $va_executable_in_hex = $ARCHIVES_MAP_VADDR; 2266 2267 return ($executable_name, $va_executable_in_hex); 2268 2269} #-- End of subroutine check_loadobjects_are_elf 2270 2271#------------------------------------------------------------------------------ 2272# Compare the current metric values against the maximum values. Mark the line 2273# if a value is within the percentage defined by $hp_value. 2274#------------------------------------------------------------------------------ 2275sub check_metric_values 2276{ 2277 my $subr_name = get_my_name (); 2278 2279 my ($metric_values, $max_metric_values_ref) = @_; 2280 2281 my @max_metric_values = @{ $max_metric_values_ref }; 2282 2283 my @current_metrics = (); 2284 my $colour_coded_line; 2285 my $current_value; 2286 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; 2287 my $max_value; 2288 my $msg; 2289 my $relative_distance; 2290 2291 @current_metrics = split (" ", $metric_values); 2292 $colour_coded_line = $FALSE; 2293 2294 for my $metric (0 .. $#current_metrics) 2295 { 2296 $current_value = $current_metrics[$metric]; 2297 if (exists ($max_metric_values[$metric])) 2298 { 2299 $max_value = $max_metric_values[$metric]; 2300 2301 $msg = "metric = $metric current_value = $current_value"; 2302 $msg .= " max_value = $max_value"; 2303 gp_message ("debugXL", $subr_name, $msg); 2304 2305 if ( ($max_value > 0) and ($current_value > 0) and 2306 ($current_value != $max_value) ) 2307 { 2308# TBD: abs needed? 2309 $msg = "metric = $metric current_value = $current_value"; 2310 $msg .= " max_value = $max_value"; 2311 gp_message ("debugXL", $subr_name, $msg); 2312 2313 $relative_distance = 1.00 - abs ( 2314 ($max_value - $current_value)/$max_value ); 2315 2316 $msg = "relative_distance = $relative_distance"; 2317 gp_message ("debugXL", $subr_name, $msg); 2318 2319 if ($relative_distance >= $hp_value/100.0) 2320 { 2321 $msg = "metric $metric is within the relative_distance"; 2322 gp_message ("debugXL", $subr_name, $msg); 2323 2324 $colour_coded_line = $TRUE; 2325 last; 2326 } 2327 } 2328 } 2329 } #-- End of loop over metrics 2330 2331 return (\$colour_coded_line); 2332 2333} #-- End of subroutine check_metric_values 2334 2335#------------------------------------------------------------------------------ 2336# Check if the system is supported. 2337#------------------------------------------------------------------------------ 2338sub check_support_for_processor 2339{ 2340 my $subr_name = get_my_name (); 2341 2342 my ($machine_ref) = @_; 2343 2344 my $machine = ${ $machine_ref }; 2345 my $is_supported; 2346 2347 if ($machine eq "x86_64") 2348 { 2349 $is_supported = $TRUE; 2350 } 2351 else 2352 { 2353 $is_supported = $FALSE; 2354 } 2355 2356 return (\$is_supported); 2357 2358} #-- End of subroutine check_support_for_processor 2359 2360#------------------------------------------------------------------------------ 2361# Check the command line options for the occurrence of experiments and make 2362# sure that this list is contigious. No other names are allowed in this list. 2363# 2364# Terminate execution in case of an error. Otherwise remove the experiment 2365# names for ARGV (to make the subsequent parsing easier), and return an array 2366# with the experiment names. 2367# 2368# The following patterns are supposed to be detected: 2369# 2370# <expdir_1> some other word(s) <expdir_2> 2371# <expdir> some other word(s) 2372#------------------------------------------------------------------------------ 2373sub check_the_experiment_list 2374{ 2375 my $subr_name = get_my_name (); 2376 2377#------------------------------------------------------------------------------ 2378# The name of an experiment directory can contain any non-whitespace 2379# character(s), but has to end with .er, or optionally .er/. Multiple 2380# forward slashes are allowed. 2381#------------------------------------------------------------------------------ 2382 my $exp_dir_regex = '^(\S+)(\.er)\/*$'; 2383 my $forward_slash_regex = '\/*$'; 2384 2385 my $current_value; 2386 my @exp_dir_list = (); 2387 my $found_experiment = $FALSE; 2388 my $found_non_exp = $FALSE; 2389 my $msg; 2390 my $name_non_exp_dir = ""; 2391 my $no_of_experiments = 0; 2392 my $no_of_invalid_dirs = 0; 2393 my $opt_remainder; 2394 my $valid = $TRUE; 2395 2396 for my $i (keys @ARGV) 2397 { 2398 $current_value = $ARGV[$i]; 2399 if ($current_value =~ /$exp_dir_regex/) 2400#------------------------------------------------------------------------------ 2401# The current value is an experiment. Remove any trailing forward slashes, 2402# Increment the count, push the value into the array and set the 2403# found_experiment flag to TRUE. 2404#------------------------------------------------------------------------------ 2405 { 2406 $no_of_experiments += 1; 2407 2408 $current_value =~ s/$forward_slash_regex//; 2409 push (@exp_dir_list, $current_value); 2410 2411 if (not $found_experiment) 2412#------------------------------------------------------------------------------ 2413# Start checking for the next field(s). 2414#------------------------------------------------------------------------------ 2415 { 2416 $found_experiment = $TRUE; 2417 } 2418#------------------------------------------------------------------------------ 2419# We had found non-experiment names and now see another experiment. Time to 2420# bail out of the loop. 2421#------------------------------------------------------------------------------ 2422 if ($found_non_exp) 2423 { 2424 last; 2425 } 2426 } 2427 else 2428 { 2429 if ($found_experiment) 2430#------------------------------------------------------------------------------ 2431# The current value is not an experiment, but the value of found_experiment 2432# indicates at least one experiment has been seen already. This means that 2433# the list of experiment names is not contiguous and that is a fatal error. 2434#------------------------------------------------------------------------------ 2435 { 2436 $name_non_exp_dir .= $current_value . " "; 2437 $found_non_exp = $TRUE; 2438 } 2439 } 2440 2441 } 2442 2443#------------------------------------------------------------------------------ 2444#------------------------------------------------------------------------------ 2445# Error handling. 2446#------------------------------------------------------------------------------ 2447#------------------------------------------------------------------------------ 2448 2449 if ($found_non_exp) 2450#------------------------------------------------------------------------------ 2451# The experiment list is not contiguous. 2452#------------------------------------------------------------------------------ 2453 { 2454 $valid = $FALSE; 2455 $msg = "the list with the experiments is not contiguous:"; 2456 gp_message ("error", $subr_name, $msg); 2457 2458 $msg = "\"" . $name_non_exp_dir. "\"". " is not an experiment, but" . 2459 " appears in a list where experiments are expected"; 2460 gp_message ("error", $subr_name, $msg); 2461 2462 $g_total_error_count++; 2463 } 2464 2465 if ($no_of_experiments == 0) 2466#------------------------------------------------------------------------------ 2467# The experiment list is empty. 2468#------------------------------------------------------------------------------ 2469 { 2470 $valid = $FALSE; 2471 $msg = "the experiment list is missing from the options"; 2472 gp_message ("error", $subr_name, $msg); 2473 2474 $g_total_error_count++; 2475 } 2476 2477 if (not $valid) 2478#------------------------------------------------------------------------------ 2479# If an error has occurred, print the error(s) and terminate execution. 2480#------------------------------------------------------------------------------ 2481 { 2482 gp_message ("abort", $subr_name, $g_abort_msg); 2483 } 2484 2485#------------------------------------------------------------------------------ 2486# We now have a list with experiments, but we still need to verify whether they 2487# exist, and if so, are these valid experiments? 2488#------------------------------------------------------------------------------ 2489 for my $exp_dir (@exp_dir_list) 2490 { 2491 $msg = "checking experiment directory $exp_dir"; 2492 gp_message ("debug", $subr_name, $msg); 2493 2494 if (-d $exp_dir) 2495 { 2496 $msg = "directory $exp_dir found"; 2497 gp_message ("debug", $subr_name, $msg); 2498#------------------------------------------------------------------------------ 2499# Files log.xml and map.xml have to be there. 2500#------------------------------------------------------------------------------ 2501 if ((-e $exp_dir."/log.xml") and (-e $exp_dir."/map.xml")) 2502 { 2503 $msg = "directory $exp_dir appears to be a valid experiment"; 2504 $msg .= " directory"; 2505 gp_message ("debug", $subr_name, $msg); 2506 } 2507 else 2508 { 2509 $no_of_invalid_dirs++; 2510 $msg = "file " . $exp_dir . "/log.xml and/or " . $exp_dir; 2511 $msg .= "/map.xml missing"; 2512 gp_message ("debug", $subr_name, $msg); 2513 2514 $msg = "directory " . get_basename($exp_dir) . " does not"; 2515 $msg .= " appear to be a valid experiment directory"; 2516 gp_message ("error", $subr_name, $msg); 2517 2518 $g_total_error_count++; 2519 } 2520 } 2521 else 2522 { 2523 $no_of_invalid_dirs++; 2524 $msg = "directory " . get_basename($exp_dir) . " does not exist"; 2525 gp_message ("error", $subr_name, $msg); 2526 2527 $g_total_error_count++; 2528 } 2529 } 2530 2531 if ($no_of_invalid_dirs > 0) 2532#------------------------------------------------------------------------------ 2533# This is a fatal error, but for now, we can continue to check for more errors. 2534# Even if none more are found, execution is terminated before the data is 2535# generated and processed. In this way we can catch as many errors as 2536# possible. 2537#------------------------------------------------------------------------------ 2538 { 2539 my $plural_or_single = ($no_of_invalid_dirs == 1) ? 2540 "one experiment is" : $no_of_invalid_dirs . " experiments are"; 2541 2542 $msg = $plural_or_single . " not valid"; 2543## gp_message ("abort", $subr_name, $msg); 2544 2545## $g_total_error_count++; 2546 } 2547 2548#------------------------------------------------------------------------------ 2549# Remove the experiments from ARGV and return the array with the experiment 2550# names. Note that these may, or may not be valid, but if invalid, execution 2551# terminates before they are used. 2552#------------------------------------------------------------------------------ 2553 for my $i (1 .. $no_of_experiments) 2554 { 2555 my $poppy = pop (@ARGV); 2556 2557 $msg = "popped $poppy from ARGV"; 2558 gp_message ("debug", $subr_name, $msg); 2559 2560 $msg = "ARGV after update = " . join (" ", @ARGV); 2561 gp_message ("debug", $subr_name, $msg); 2562 } 2563 2564 return (\@exp_dir_list); 2565 2566} #-- End of subroutine check_the_experiment_list 2567 2568#------------------------------------------------------------------------------ 2569# Perform multiple checks on the experiment directories. 2570# 2571# TBD: It needs to be investigated whether all of this is really neccesary. 2572#------------------------------------------------------------------------------ 2573sub check_validity_exp_dirs 2574{ 2575 my $subr_name = get_my_name (); 2576 2577 my ($exp_dir_list_ref) = @_; 2578 2579 my @exp_dir_list = @{ $exp_dir_list_ref }; 2580 2581 my %elf_rats = (); 2582 2583 my $dir_not_found = $FALSE; 2584 my $missing_dirs = 0; 2585 my $invalid_dirs = 0; 2586 2587 my $archive_dir_not_empty; 2588 my $archives_dir; 2589 my $archives_file; 2590 my $count_exp_dir_not_elf; 2591 my $elf_magic_number; 2592 my $first_line; 2593 my $msg; 2594 2595 my $first_time; 2596 my $filename; 2597 2598 my $comment; 2599 2600 my $selected_archive_has_elf_format; 2601 2602 my $selected_archive; 2603 my $archive_dir_selected; 2604 my $no_of_files_in_selected_archive; 2605 2606#------------------------------------------------------------------------------ 2607# Initialize ELF status to FALSE. 2608#------------------------------------------------------------------------------ 2609## for my $exp_dir (@exp_dir_list) 2610 for my $exp_dir (keys %g_exp_dir_meta_data) 2611 { 2612 $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE; 2613 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; 2614 } 2615#------------------------------------------------------------------------------ 2616# Check if the load objects are in ELF format. 2617#------------------------------------------------------------------------------ 2618 for my $exp_dir (keys %g_exp_dir_meta_data) 2619 { 2620 $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; 2621 $archives_dir .= $exp_dir . "/archives"; 2622 $archive_dir_not_empty = $FALSE; 2623 $first_time = $TRUE; 2624 $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE; 2625 $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0; 2626 2627 $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = "; 2628 $msg .= $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}; 2629 gp_message ("debug", $subr_name, $msg); 2630 2631 $msg = "checking $archives_dir"; 2632 gp_message ("debug", $subr_name, $msg); 2633 2634 while (glob ("$archives_dir/*")) 2635 { 2636 $filename = get_basename ($_); 2637 2638 $msg = "processing file: $filename"; 2639 gp_message ("debug", $subr_name, $msg); 2640 2641 $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE; 2642 $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++; 2643 2644 $archive_dir_not_empty = $TRUE; 2645#------------------------------------------------------------------------------ 2646# Replaces the ELF_RATS part in elf_phdr. 2647# 2648# Challenge: splittable_mrg.c_I0txnOW_Wn5 2649# 2650# TBD: Store this for each relevant experiment directory. 2651#------------------------------------------------------------------------------ 2652 my $last_dot = rindex ($filename,"."); 2653 my $underscore_before_dot = $TRUE; 2654 my $first_underscore = -1; 2655 2656 $msg = "last_dot = $last_dot"; 2657 gp_message ("debugXL", $subr_name, $msg); 2658 2659 while ($underscore_before_dot) 2660 { 2661 $first_underscore = index ($filename, "_", $first_underscore+1); 2662 if ($last_dot < $first_underscore) 2663 { 2664 $underscore_before_dot = $FALSE; 2665 } 2666 } 2667 my $original_name = substr ($filename, 0, $first_underscore); 2668 $msg = "stripped archive name: " . $original_name; 2669 gp_message ("debug", $subr_name, $msg); 2670 if (not exists ($elf_rats{$original_name})) 2671 { 2672 $elf_rats{$original_name} = [$filename, $exp_dir]; 2673 } 2674#------------------------------------------------------------------------------ 2675# We only need to detect the presence of an object once. 2676#------------------------------------------------------------------------------ 2677 if ($first_time) 2678 { 2679 $first_time = $FALSE; 2680 $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE; 2681 $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = "; 2682 $msg .= $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; 2683 2684 gp_message ("debugXL", $subr_name, $msg); 2685 } 2686 } 2687 } #-- End of loop over experiment directories 2688 2689 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2690 { 2691 my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; 2692 $msg = "archive directory " . $exp_dir . "/archives is"; 2693 $msg .= " " . ($empty ? "empty" : "not empty"); 2694 gp_message ("debug", $subr_name, $msg); 2695 } 2696 2697#------------------------------------------------------------------------------ 2698# Verify that all relevant files in the archive directories are in ELF format. 2699#------------------------------------------------------------------------------ 2700 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2701 { 2702 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE; 2703 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2704 { 2705 $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; 2706 $archives_dir .= $exp_dir . "/archives"; 2707 $msg = "exp_dir = " . $exp_dir . " archives_dir = " . $archives_dir; 2708 gp_message ("debug", $subr_name, $msg); 2709#------------------------------------------------------------------------------ 2710# Check if any of the loadobjects is of type ELF. Bail out on the first one 2711# found. The assumption is that all other loadobjects must be of type ELF too 2712# then. 2713#------------------------------------------------------------------------------ 2714 for my $aname (sort keys 2715 %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) 2716 { 2717 $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; 2718 $filename .= $exp_dir . "/archives/" . $aname; 2719 $msg = " - unable to open file $filename for reading:"; 2720 open (ARCF,"<", $filename) 2721 or die ($subr_name . $msg . " " . $!); 2722 2723 $first_line = <ARCF>; 2724 close (ARCF); 2725 2726#------------------------------------------------------------------------------ 2727# The first 4 hex fields in the header of an ELF file are: 7F 45 4c 46 (7FELF). 2728# 2729# See also https://en.wikipedia.org/wiki/Executable_and_Linkable_Format 2730#------------------------------------------------------------------------------ 2731# if ($first_line =~ /^\177ELF.*/) 2732 2733 $elf_magic_number = unpack ('H8', $first_line); 2734 if ($elf_magic_number eq "7f454c46") 2735 { 2736 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = 2737 $TRUE; 2738 $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE; 2739 last; 2740 } 2741 } 2742 } 2743 } 2744 2745 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2746 { 2747 $msg = "the loadobjects in the archive in $exp_dir are"; 2748 $msg .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? 2749 " in" : " not in"; 2750 $msg .= " ELF format"; 2751 gp_message ("debug", $subr_name, $msg); 2752 } 2753 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2754 { 2755 if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2756 { 2757 $msg = "there are no archived files in " . $exp_dir; 2758 gp_message ("debug", $subr_name, $msg); 2759 } 2760 } 2761 2762#------------------------------------------------------------------------------ 2763# If there are archived files and they are not in ELF format, a debug message 2764# is issued. 2765# 2766# TBD: Bail out? 2767#------------------------------------------------------------------------------ 2768 $count_exp_dir_not_elf = 0; 2769 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2770 { 2771 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) 2772 { 2773 $count_exp_dir_not_elf++; 2774 } 2775 } 2776 if ($count_exp_dir_not_elf != 0) 2777 { 2778 $msg = "there are $count_exp_dir_not_elf experiments with non-ELF"; 2779 $msg .= " load objects"; 2780 gp_message ("debug", $subr_name, $msg); 2781 } 2782 2783#------------------------------------------------------------------------------ 2784# Select the experiment directory that is used for the files in the archive. 2785# By default, a directory with archived files is used, but in case this does 2786# not exist, a directory without archived files is selected. Obviously this 2787# needs to be dealt with later on. 2788#------------------------------------------------------------------------------ 2789 2790#------------------------------------------------------------------------------ 2791# Try the experiments with archived files first. 2792#------------------------------------------------------------------------------ 2793 $archive_dir_not_empty = $FALSE; 2794 $archive_dir_selected = $FALSE; 2795## for my $exp_dir (sort @exp_dir_list) 2796 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2797 { 2798 $msg = "exp_dir = " . $exp_dir; 2799 gp_message ("debugXL", $subr_name, $msg); 2800 $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}"; 2801 $msg .= " = " . $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; 2802 gp_message ("debugXL", $subr_name, $msg); 2803 2804 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2805 { 2806 $selected_archive = $exp_dir; 2807 $archive_dir_not_empty = $TRUE; 2808 $archive_dir_selected = $TRUE; 2809 $selected_archive_has_elf_format = 2810 ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ? 2811 $TRUE : $FALSE; 2812 last; 2813 } 2814 } 2815 if (not $archive_dir_selected) 2816#------------------------------------------------------------------------------ 2817# None are found and pick the first one without archived files. 2818#------------------------------------------------------------------------------ 2819 { 2820 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2821 { 2822 if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2823 { 2824 $selected_archive = $exp_dir; 2825 $archive_dir_not_empty = $FALSE; 2826 $archive_dir_selected = $TRUE; 2827 $selected_archive_has_elf_format = $FALSE; 2828 last; 2829 } 2830 } 2831 } 2832 2833 $msg = "experiment $selected_archive has been selected for"; 2834 $msg .= " archive analysis"; 2835 gp_message ("debug", $subr_name, $msg); 2836 $msg = "this archive is"; 2837 $msg .= $archive_dir_not_empty ? " not empty" : " empty"; 2838 gp_message ("debug", $subr_name, $msg); 2839 $msg = "this archive is"; 2840 $msg .= $selected_archive_has_elf_format ? " in" : " not in"; 2841 $msg .= " ELF format"; 2842 gp_message ("debug", $subr_name, $msg); 2843#------------------------------------------------------------------------------ 2844# Get the size of the hash that contains the archived files. 2845#------------------------------------------------------------------------------ 2846## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES); 2847 2848 $no_of_files_in_selected_archive = 2849 $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"}; 2850 2851 $msg = "number of files in archive $selected_archive is"; 2852 $msg .= " " . $no_of_files_in_selected_archive; 2853 gp_message ("debug", $subr_name, $msg); 2854 2855 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2856 { 2857 my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}; 2858 $msg = "archive directory $exp_dir/archives is"; 2859 $msg .= $is_empty ? " empty" : " not empty"; 2860 gp_message ("debug", $subr_name, $msg); 2861 } 2862 for my $exp_dir (sort keys %g_exp_dir_meta_data) 2863 { 2864 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"}) 2865 { 2866 for my $object (sort keys 2867 %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}}) 2868 { 2869 $msg = $exp_dir . " " . $object . " "; 2870 $msg .= 2871 $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object}; 2872 gp_message ("debug", $subr_name, $msg); 2873 } 2874 } 2875 } 2876 2877 return ($archive_dir_not_empty, $selected_archive, \%elf_rats); 2878 2879} #-- End of subroutine check_validity_exp_dirs 2880 2881#------------------------------------------------------------------------------ 2882# Color the string and optionally mark it boldface. 2883# 2884# For supported colors, see: 2885# https://www.w3schools.com/colors/colors_names.asp 2886#------------------------------------------------------------------------------ 2887sub color_string 2888{ 2889 my $subr_name = get_my_name (); 2890 2891 my ($input_string, $boldface, $color) = @_; 2892 2893 my $colored_string; 2894 2895 $colored_string = "<font color='" . $color . "'>"; 2896 2897 if ($boldface) 2898 { 2899 $colored_string .= "<b>"; 2900 } 2901 2902 $colored_string .= $input_string; 2903 2904 if ($boldface) 2905 { 2906 $colored_string .= "</b>"; 2907 } 2908 $colored_string .= "</font>"; 2909 2910 return ($colored_string); 2911 2912} #-- End of subroutine color_string 2913 2914#------------------------------------------------------------------------------ 2915# Generate the array with the info on the experiment(s). 2916#------------------------------------------------------------------------------ 2917sub create_exp_info 2918{ 2919 my $subr_name = get_my_name (); 2920 2921 my ($experiment_dir_list_ref, $experiment_data_ref) = @_; 2922 2923 my @experiment_dir_list = @{ $experiment_dir_list_ref }; 2924 my @experiment_data = @{ $experiment_data_ref }; 2925 2926 my @experiment_stats_html = (); 2927 my $experiment_stats_line; 2928 my $msg; 2929 my $plural; 2930 2931 $plural = ($#experiment_dir_list > 0) ? "s:" : ":"; 2932 2933 $experiment_stats_line = "<h3>\n"; 2934 $experiment_stats_line .= "Full pathnames to the input experiment"; 2935 $experiment_stats_line .= $plural . "\n"; 2936 $experiment_stats_line .= "</h3>\n"; 2937 $experiment_stats_line .= "<pre>\n"; 2938 2939 for my $i (0 .. $#experiment_dir_list) 2940 { 2941 $experiment_stats_line .= $experiment_dir_list[$i] . " (" ; 2942 $experiment_stats_line .= $experiment_data[$i]{"start_date"} . ")\n"; 2943 } 2944 $experiment_stats_line .= "</pre>\n"; 2945 2946 push (@experiment_stats_html, $experiment_stats_line); 2947 2948 $msg = "experiment_stats_line = " . $experiment_stats_line; 2949 gp_message ("debugXL", $subr_name, $msg); 2950 2951 return (\@experiment_stats_html); 2952 2953} #-- End of subroutine create_exp_info 2954 2955#------------------------------------------------------------------------------ 2956# Trivial function to generate a tag. This has been made a function to ensure 2957# consistency creating tags and also make it easier to change them. 2958#------------------------------------------------------------------------------ 2959sub create_function_tag 2960{ 2961 my $subr_name = get_my_name (); 2962 2963 my ($tag_id) = @_; 2964 2965 my $function_tag = "function_tag_" . $tag_id; 2966 2967 return ($function_tag); 2968 2969} #-- End of subroutine create_function_tag 2970 2971#------------------------------------------------------------------------------ 2972# Generate and return a string with the credits. Note that this also ends 2973# the HTML formatting controls. 2974#------------------------------------------------------------------------------ 2975sub create_html_credits 2976{ 2977 my $subr_name = get_my_name (); 2978 2979 my $msg; 2980 my $the_date; 2981 2982 my @months = qw (January February March April May June July 2983 August September October November December); 2984 2985 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = 2986 localtime (); 2987 2988 $year += 1900; 2989 2990 $the_date = $months[$mon] . " " . $mday . ", " . $year; 2991 2992 $msg = "<i>\n"; 2993 $msg .= "Output generated by the $driver_cmd command "; 2994 $msg .= "on $the_date "; 2995 $msg .= "(GNU binutils version " . $binutils_version . ")"; 2996 $msg .= "\n"; 2997 $msg .= "</i>"; 2998 2999 gp_message ("debug", $subr_name, "the date = $the_date"); 3000 3001 return (\$msg); 3002 3003} #-- End of subroutine create_html_credits 3004 3005#------------------------------------------------------------------------------ 3006# Generate a string that contains all the necessary HTML header information, 3007# plus a title. 3008# 3009# See also https://www.w3schools.com for the details on the features used. 3010#------------------------------------------------------------------------------ 3011sub create_html_header 3012{ 3013 my $subr_name = get_my_name (); 3014 3015 my ($title_ref) = @_; 3016 3017 my $title = ${ $title_ref }; 3018 3019 my $LANG = $g_locale_settings{"LANG"}; 3020 my $background_color = $g_html_color_scheme{"background_color_page"}; 3021 3022 my $html_header; 3023 3024 $html_header = "<!DOCTYPE html public \"-//w3c//dtd html 3.2//en\">\n"; 3025 $html_header .= "<html lang=\"$LANG\">\n"; 3026 $html_header .= "<head>\n"; 3027 $html_header .= "<meta http-equiv=\"content-type\""; 3028 $html_header .= " content=\"text/html; charset=iso-8859-1\">\n"; 3029 $html_header .= "<title>" . $title . "</title>\n"; 3030 $html_header .= "</head>\n"; 3031 $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n"; 3032 $html_header .= "<style>\n"; 3033 $html_header .= "div.left {\n"; 3034 $html_header .= "text-align: left;\n"; 3035 $html_header .= "}\n"; 3036 $html_header .= "div.right {\n"; 3037 $html_header .= "text-align: right;\n"; 3038 $html_header .= "}\n"; 3039 $html_header .= "div.center {\n"; 3040 $html_header .= "text-align: center;\n"; 3041 $html_header .= "}\n"; 3042 $html_header .= "div.justify {\n"; 3043 $html_header .= "text-align: justify;\n"; 3044 $html_header .= "}\n"; 3045 $html_header .= "</style>"; 3046 3047 return (\$html_header); 3048 3049} #-- End of subroutine create_html_header 3050 3051#------------------------------------------------------------------------------ 3052# Create a complete table. 3053#------------------------------------------------------------------------------ 3054sub create_table 3055{ 3056 my $subr_name = get_my_name (); 3057 3058 my ($experiment_data_ref, $table_definition_ref) = @_; 3059 3060 my @experiment_data = @{ $experiment_data_ref }; 3061 my @table_definition = @{ $table_definition_ref }; 3062 3063 my @html_exp_table_data = (); 3064 my $html_header_line; 3065 my $html_table_line; 3066 my $html_end_table; 3067 3068 $html_header_line = ${ create_table_header_exp (\@experiment_data) }; 3069 3070 push (@html_exp_table_data, $html_header_line); 3071 3072 for my $i (sort keys @table_definition) 3073 { 3074 $html_table_line = ${ 3075 create_table_entry_exp (\$table_definition[$i]{"name"}, 3076 \$table_definition[$i]{"key"}, 3077 \@experiment_data) }; 3078 push (@html_exp_table_data, $html_table_line); 3079 3080 my $msg = "i = $i html_table_line = $html_table_line"; 3081 gp_message ("debugXL", $subr_name, $msg); 3082 } 3083 3084 $html_end_table = "</table>\n"; 3085 push (@html_exp_table_data, $html_end_table); 3086 3087 return (\@html_exp_table_data); 3088 3089} #-- End of subroutine create_table 3090 3091#------------------------------------------------------------------------------ 3092# Create one row for the table with experiment info. 3093#------------------------------------------------------------------------------ 3094sub create_table_entry_exp 3095{ 3096 my $subr_name = get_my_name (); 3097 3098 my ($entry_name_ref, $key_ref, $experiment_data_ref) = @_; 3099 3100 my $entry_name = ${ $entry_name_ref }; 3101 my $key = ${ $key_ref }; 3102 my @experiment_data = @{ $experiment_data_ref }; 3103 3104 my $html_line; 3105 my $msg; 3106 3107 $msg = "entry_name = $entry_name key = $key"; 3108 gp_message ("debugXL", $subr_name, $msg); 3109 3110## $html_line = "<tr><div class=\"left\"><td><b> "; 3111 $html_line = "<tr><div class=\"right\"><td><b> "; 3112 $html_line .= $entry_name; 3113 $html_line .= " </b></td>"; 3114 for my $i (sort keys @experiment_data) 3115 { 3116 if (exists ($experiment_data[$i]{$key})) 3117 { 3118 $html_line .= "<td> " . $experiment_data[$i]{$key}; 3119 $html_line .= " </td>"; 3120 } 3121 else 3122 { 3123 $msg = "experiment_data[$i]{$key} does not exist"; 3124## gp_message ("assertion", $subr_name, $msg); 3125# TBD: warning or error? 3126 gp_message ("warning", $subr_name, $msg); 3127 } 3128 } 3129 $html_line .= "</div></tr>\n"; 3130 3131 gp_message ("debugXL", $subr_name, "return html_line = $html_line"); 3132 3133 return (\$html_line); 3134 3135} #-- End of subroutine create_table_entry_exp 3136 3137#------------------------------------------------------------------------------ 3138# Create the table header for the experiment info. 3139#------------------------------------------------------------------------------ 3140sub create_table_header_exp 3141{ 3142 my $subr_name = get_my_name (); 3143 3144 my ($experiment_data_ref) = @_; 3145 3146 my @experiment_data = @{ $experiment_data_ref }; 3147 my $html_header_line; 3148 my $msg; 3149 3150 $html_header_line = "<style>\n"; 3151 $html_header_line .= "table, th, td {\n"; 3152 $html_header_line .= "border: 1px solid black;\n"; 3153 $html_header_line .= "border-collapse: collapse;\n"; 3154 $html_header_line .= "}\n"; 3155 $html_header_line .= "</style>\n"; 3156 $html_header_line .= "</pre>\n"; 3157 $html_header_line .= "<table>\n"; 3158 $html_header_line .= "<tr><div class=\"center\"><th></th>"; 3159 3160 for my $i (sort keys @experiment_data) 3161 { 3162 $html_header_line .= "<th> Experiment ID "; 3163 $html_header_line .= $experiment_data[$i]{"exp_id"} . " </th>"; 3164 } 3165 $html_header_line .= "</div></tr>\n"; 3166 3167 $msg = "html_header_line = " . $html_header_line; 3168 gp_message ("debugXL", $subr_name, $msg); 3169 3170 return (\$html_header_line); 3171 3172} #-- End of subroutine create_table_header_exp 3173 3174#------------------------------------------------------------------------------ 3175# Handle where the output should go. If needed, a directory is created where 3176# the results will go. 3177#------------------------------------------------------------------------------ 3178sub define_the_output_directory 3179{ 3180 my $subr_name = get_my_name (); 3181 3182 my ($define_new_output_dir, $overwrite_output_dir) = @_; 3183 3184 my $msg; 3185 my $outputdir; 3186 3187#------------------------------------------------------------------------------ 3188# If neither -o or -O are set, find the next number to be used in the name for 3189# the default output directory. 3190#------------------------------------------------------------------------------ 3191 if ((not $define_new_output_dir) and (not $overwrite_output_dir)) 3192 { 3193 my $dir_id = 1; 3194 while (-d "er.".$dir_id.".html") 3195 { $dir_id++; } 3196 $outputdir = "er.".$dir_id.".html"; 3197 } 3198 3199 if (-d $outputdir) 3200 { 3201#------------------------------------------------------------------------------ 3202# The -o option is used, but the directory already exists. 3203#------------------------------------------------------------------------------ 3204 if ($define_new_output_dir) 3205 { 3206 $msg = "directory $outputdir already exists"; 3207 gp_message ("error", $subr_name, $msg); 3208 $g_total_error_count++; 3209 3210 $msg = "use the -O/--overwrite option to overwrite an existing"; 3211 $msg .= " directory"; 3212 gp_message ("abort", $subr_name, $msg); 3213 } 3214#------------------------------------------------------------------------------ 3215# This is a bit risky, so we proceed with caution. The output directory exists, 3216# but it is okay to overwrite it. It is removed here and created again below. 3217#------------------------------------------------------------------------------ 3218 elsif ($overwrite_output_dir) 3219 { 3220 my $target_cmd = $g_mapped_cmds{"rm"}; 3221 my $rm_output = qx ($target_cmd -rf $outputdir); 3222 my $error_code = ${^CHILD_ERROR_NATIVE}; 3223 if ($error_code != 0) 3224 { 3225 gp_message ("error", $subr_name, $rm_output); 3226 $msg = "fatal error when trying to remove " . $outputdir; 3227 gp_message ("abort", $subr_name, $msg); 3228 } 3229 else 3230 { 3231 $msg = "directory $outputdir has been removed"; 3232 gp_message ("debug", $subr_name, $msg); 3233 } 3234 } 3235 } 3236#------------------------------------------------------------------------------ 3237# When we get here, the fatal scenarios have been cleared and the name for 3238# $outputdir is known. Time to create it. 3239#------------------------------------------------------------------------------ 3240 if (mkdir ($outputdir, 0777)) 3241 { 3242 $msg = "created output directory " . $outputdir; 3243 gp_message ("debug", $subr_name, $msg); 3244 } 3245 else 3246 { 3247 $msg = "a fatal problem occurred when creating directory " . $outputdir; 3248 gp_message ("abort", $subr_name, $msg); 3249 } 3250 3251 return ($outputdir); 3252 3253} #-- End of subroutine define_the_output_directory 3254 3255#------------------------------------------------------------------------------ 3256# Return the virtual address for the load object. 3257# 3258# Note that at this point, $elf_arch is known to be supported. 3259# 3260# TBD: Duplications? 3261#------------------------------------------------------------------------------ 3262sub determine_base_va_address 3263{ 3264 my $subr_name = get_my_name (); 3265 3266 my ($executable_name, $base_va_executable, $loadobj, $routine) = @_; 3267 3268 my $msg; 3269 my $name_loadobject; 3270 my $base_va_address; 3271 3272 $msg = "base_va_executable = " . $base_va_executable; 3273 gp_message ("debugXL", $subr_name, $msg); 3274 $msg = "loadobj = " . $loadobj; 3275 gp_message ("debugXL", $subr_name, $msg); 3276 $msg = "routine = " . $routine; 3277 gp_message ("debugXL", $subr_name, $msg); 3278 3279#------------------------------------------------------------------------------ 3280# Strip the pathname from the load object name. 3281#------------------------------------------------------------------------------ 3282 $name_loadobject = get_basename ($loadobj); 3283 3284#------------------------------------------------------------------------------ 3285# If the load object is the executable, return the base address determined 3286# earlier. Otherwise return 0x0. Note that I am not sure if this is always 3287# the right thing to do, but for .so files it seems to work out fine. 3288#------------------------------------------------------------------------------ 3289 if ($name_loadobject eq $executable_name) 3290 { 3291 $base_va_address = $base_va_executable; 3292 } 3293 else 3294 { 3295 $base_va_address = "0x0"; 3296 } 3297 3298 my $decimal_address = bigint::hex ($base_va_address); 3299 3300 $msg = "return base_va_address = $base_va_address"; 3301 $msg .= " (decimal: $decimal_address)"; 3302 gp_message ("debugXL", $subr_name, $msg); 3303 3304 return ($base_va_address); 3305 3306} #-- End of subroutine determine_base_va_address 3307 3308#------------------------------------------------------------------------------ 3309# Now that we know the map.xml file(s) are present, we can scan these and get 3310# the required information. 3311#------------------------------------------------------------------------------ 3312sub determine_base_virtual_address 3313{ 3314 my $subr_name = get_my_name (); 3315 3316 my ($exp_dir_list_ref) = @_; 3317 3318 my @exp_dir_list = @{ $exp_dir_list_ref }; 3319 3320 my $executable_name; 3321 my $full_path_exec; 3322 my $msg; 3323 my $path_to_map_file; 3324 my $va_executable_in_hex; 3325 3326 for my $exp_dir (keys %g_exp_dir_meta_data) 3327 { 3328 $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"}; 3329 $path_to_map_file .= $exp_dir; 3330 $path_to_map_file .= "/map.xml"; 3331 3332 ($full_path_exec, $executable_name, $va_executable_in_hex) = 3333 extract_info_from_map_xml ($path_to_map_file); 3334 3335 $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"} = $full_path_exec; 3336 $g_exp_dir_meta_data{$exp_dir}{"exec_name"} = $executable_name; 3337 $g_exp_dir_meta_data{$exp_dir}{"va_base_in_hex"} = $va_executable_in_hex; 3338 3339 $msg = "exp_dir = " . $exp_dir; 3340 gp_message ("debug", $subr_name, $msg); 3341 $msg = "full_path_exece = " . $full_path_exec; 3342 gp_message ("debug", $subr_name, $msg); 3343 $msg = "executable_name = " . $executable_name; 3344 gp_message ("debug", $subr_name, $msg); 3345 $msg = "va_executable_in_hex = " . $va_executable_in_hex; 3346 gp_message ("debug", $subr_name, $msg); 3347 } 3348 3349 return (0); 3350 3351} #-- End of subroutine determine_base_virtual_address 3352 3353#------------------------------------------------------------------------------ 3354# Determine whether the decimal separator is a point or a comma. 3355#------------------------------------------------------------------------------ 3356sub determine_decimal_separator 3357{ 3358 my $subr_name = get_my_name (); 3359 3360 my $cmd_output; 3361 my $convert_to_dot; 3362 my $decimal_separator; 3363 my $error_code; 3364 my $field; 3365 my $ignore_count; 3366 my @locale_info = (); 3367 my $msg; 3368 my $target_cmd; 3369 my $target_found; 3370 3371 my $default_decimal_separator = "\\."; 3372 3373 $target_cmd = $g_mapped_cmds{locale} . " -k LC_NUMERIC"; 3374 ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); 3375 3376 if ($error_code != 0) 3377#------------------------------------------------------------------------------ 3378# This is unlikely to happen, but you never know. To reduce the nesting level, 3379# return right here in case of an error. 3380#------------------------------------------------------------------------------ 3381 { 3382 $msg = "failure to execute the command " . $target_cmd; 3383 gp_message ("error", $subr_name, $msg); 3384 3385 $g_total_error_count++; 3386 3387 $convert_to_dot = $TRUE; 3388 3389 return ($error_code, $default_decimal_separator, $convert_to_dot); 3390 } 3391 3392#------------------------------------------------------------------------------ 3393#------------------------------------------------------------------------------ 3394# Scan the locale info and search for the target line of the form 3395# decimal_point="<target>" where <target> is either a dot, or a comma. 3396#------------------------------------------------------------------------------ 3397#------------------------------------------------------------------------------ 3398 3399#------------------------------------------------------------------------------ 3400# Split the output into the different lines and scan for the line we need. 3401#------------------------------------------------------------------------------ 3402 @locale_info = split ("\n", $cmd_output); 3403 $target_found = $FALSE; 3404 for my $line (@locale_info) 3405 { 3406 chomp ($line); 3407 $msg = "line from locale_info = " . $line; 3408 gp_message ("debug", $subr_name, $msg); 3409 3410 if ($line =~ /decimal_point=/) 3411 { 3412 3413#------------------------------------------------------------------------------ 3414# Found the target line. Split this line to get the value field. 3415#------------------------------------------------------------------------------ 3416 my @split_line = split ("=", $line); 3417 3418#------------------------------------------------------------------------------ 3419# There should be 2 fields. If not, something went wrong. 3420#------------------------------------------------------------------------------ 3421 if (scalar @split_line != 2) 3422 { 3423# if (scalar @split_line == 2) { 3424# $target_found = $FALSE; 3425#------------------------------------------------------------------------------ 3426# Remove the newline before printing the variables. 3427#------------------------------------------------------------------------------ 3428 $ignore_count = chomp ($line); 3429 $ignore_count = chomp (@split_line); 3430 3431 $msg = "line $line matches the search, but the decimal"; 3432 $msg .= " separator has the wrong format"; 3433 gp_message ("warning", $subr_name, $msg); 3434 $msg = "the splitted line is [@split_line] and does not"; 3435 $msg .= " contain 2 fields"; 3436 gp_message ("warning", $subr_name, $msg); 3437 $msg = "the default decimal separator will be used"; 3438 gp_message ("warning", $subr_name, $msg); 3439 3440 $g_total_warning_count++; 3441 } 3442 else 3443 { 3444#------------------------------------------------------------------------------ 3445# We know there are 2 fields and the second one has the decimal point. 3446#------------------------------------------------------------------------------ 3447 $msg = "split_line[1] = " . $split_line[1]; 3448 gp_message ("debug", $subr_name, $msg); 3449 3450 chomp ($split_line[1]); 3451 $field = $split_line[1]; 3452 3453 if (length ($field) != 3) 3454#------------------------------------------------------------------------------ 3455# The field still includes the quotes. Check if the string has length 3, which 3456# should be the case, but if not, we flag an error. The error code is set such 3457# that the callee will know a problem has occurred. 3458#------------------------------------------------------------------------------ 3459 { 3460 $msg = "unexpected output from the $target_cmd command:"; 3461 $msg .= " " . $field; 3462 gp_message ("error", $subr_name, $msg); 3463 3464 $g_total_error_count++; 3465 3466 $error_code = 1; 3467 last; 3468 } 3469 3470 $msg = "field = ->$field<-"; 3471 gp_message ("debug", $subr_name, $msg); 3472 3473 if (($field eq "\".\"") or ($field eq "\",\"")) 3474#------------------------------------------------------------------------------ 3475# Found the separator. Capture the character between the quotes. 3476#------------------------------------------------------------------------------ 3477 { 3478 $target_found = $TRUE; 3479 $decimal_separator = substr ($field,1,1); 3480 $msg = "decimal_separator = $decimal_separator--end"; 3481 $msg .= " skip remainder of loop"; 3482 gp_message ("debug", $subr_name, $msg); 3483 last; 3484 } 3485 } 3486 } 3487 } 3488 if (not $target_found) 3489 { 3490 $decimal_separator = $default_decimal_separator; 3491 $msg = "cannot determine the decimal separator"; 3492 $msg .= " - use the default " . $decimal_separator; 3493 gp_message ("warning", $subr_name, $msg); 3494 3495 $g_total_warning_count++; 3496 } 3497 3498 if ($decimal_separator ne ".") 3499 { 3500 $convert_to_dot = $TRUE; 3501 } 3502 else 3503 { 3504 $convert_to_dot = $FALSE; 3505 } 3506 3507 $decimal_separator = "\\".$decimal_separator; 3508 $g_locale_settings{"decimal_separator"} = $decimal_separator; 3509 $g_locale_settings{"convert_to_dot"} = $convert_to_dot; 3510 3511 return ($error_code, $decimal_separator, $convert_to_dot); 3512 3513} #-- End of subroutine determine_decimal_separator 3514 3515#------------------------------------------------------------------------------ 3516# TBD 3517#------------------------------------------------------------------------------ 3518sub dump_function_info 3519{ 3520 my $subr_name = get_my_name (); 3521 3522 my ($function_info_ref, $name) = @_; 3523 3524 my %function_info = %{$function_info_ref}; 3525 my $kip; 3526 my $msg; 3527 3528 $msg = "function_info for " . $name; 3529 gp_message ("debug", $subr_name, $msg); 3530 3531 $kip = 0; 3532 for my $farray ($function_info{$name}) 3533 { 3534 for my $elm (@{$farray}) 3535 { 3536 $msg = $kip . ": routine = " . ${$elm}{"routine"}; 3537 gp_message ("debug", $subr_name, $msg); 3538 for my $key (sort keys %{$elm}) 3539 { 3540 if ($key eq "routine") 3541 { 3542 next; 3543 } 3544 $msg = $kip . ": $key = " . ${$elm}{$key}; 3545 gp_message ("debug", $subr_name, $msg); 3546 } 3547 $kip++; 3548 } 3549 } 3550 3551 return (0); 3552 3553} #-- End of subroutine dump_function_info 3554 3555#------------------------------------------------------------------------------ 3556# TBD 3557#------------------------------------------------------------------------------ 3558sub elf_phdr 3559{ 3560 my $subr_name = get_my_name (); 3561 3562 my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine, 3563 $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_; 3564 3565 my %elf_rats = %{$elf_rats_ref}; 3566 3567 my $msg; 3568 my $return_value; 3569 3570#------------------------------------------------------------------------------ 3571# TBD. Quick check. Can be moved up the call tree. 3572#------------------------------------------------------------------------------ 3573 if ( $elf_arch ne "Linux" ) 3574 { 3575 $msg = $elf_arch . " is not a supported OS"; 3576 gp_message ("error", $subr_name, $msg); 3577 $g_total_error_count++; 3578 gp_message ("abort", $subr_name, $g_abort_msg); 3579 } 3580 3581#------------------------------------------------------------------------------ 3582# TBD: This should not be in a loop over $loadobj and only use the executable. 3583#------------------------------------------------------------------------------ 3584 3585#------------------------------------------------------------------------------ 3586# TBD: $routine is not really used in these subroutines. Is this a bug? 3587#------------------------------------------------------------------------------ 3588 if ($elf_loadobjects_found) 3589 { 3590 gp_message ("debugXL", $subr_name, "calling elf_phdr_usual"); 3591 $return_value = elf_phdr_usual ($elf_arch, 3592 $loadobj, 3593 $routine, 3594 \%elf_rats); 3595 } 3596 else 3597 { 3598 gp_message ("debugXL", $subr_name, "calling elf_phdr_sometimes"); 3599 $return_value = elf_phdr_sometimes ($elf_arch, 3600 $loadobj, 3601 $routine, 3602 $ARCHIVES_MAP_NAME, 3603 $ARCHIVES_MAP_VADDR); 3604 } 3605 3606 gp_message ("debug", $subr_name, "the return value = $return_value"); 3607 3608 if (not $return_value) 3609 { 3610 $msg = "need to handle a return value of FALSE"; 3611 gp_message ("error", $subr_name, $msg); 3612 $g_total_error_count++; 3613 gp_message ("abort", $subr_name, $g_abort_msg); 3614 } 3615 3616 return ($return_value); 3617 3618} #-- End of subroutine elf_phdr 3619 3620#------------------------------------------------------------------------------ 3621# Return the virtual address for the load object. 3622#------------------------------------------------------------------------------ 3623sub elf_phdr_sometimes 3624{ 3625 my $subr_name = get_my_name (); 3626 3627 my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME, 3628 $ARCHIVES_MAP_VADDR) = @_; 3629 3630 my $arch_uname_s = $local_system_config{"kernel_name"}; 3631 my $arch_uname = $local_system_config{"processor"}; 3632 my $arch = $g_arch_specific_settings{"arch"}; 3633 3634 gp_message ("debug", $subr_name, "arch_uname_s = $arch_uname_s"); 3635 gp_message ("debug", $subr_name, "arch_uname = $arch_uname"); 3636 gp_message ("debug", $subr_name, "arch = $arch"); 3637 3638 my $cmd_output; 3639 my $command_string; 3640 my $error_code; 3641 my $msg; 3642 my $target_cmd; 3643 3644 my $line; 3645 my $blo; 3646 3647 my $elf_offset; 3648 my $i; 3649 my @foo; 3650 my $foo; 3651 my $foo1; 3652 my $p_vaddr; 3653 my $rc; 3654 my $archives_file; 3655 my $loadobj_SAVE; 3656 my $Offset; 3657 my $VirtAddr; 3658 my $PhysAddr; 3659 my $FileSiz; 3660 my $MemSiz; 3661 my $Flg; 3662 my $Align; 3663 3664 if ($ARCHIVES_MAP_NAME eq $blo) 3665 { 3666 return ($ARCHIVES_MAP_VADDR); 3667 } 3668 else 3669 { 3670 return ($FALSE); 3671 } 3672 3673 if ($arch_uname_s ne $elf_arch) 3674 { 3675#------------------------------------------------------------------------------ 3676# We are masquerading between systems, must leave 3677#------------------------------------------------------------------------------ 3678 $msg = "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch"; 3679 gp_message ("debug", $subr_name, $msg); 3680 return ($FALSE); 3681 } 3682 3683 if ($loadobj eq "DYNAMIC_FUNCTIONS") 3684#------------------------------------------------------------------------------ 3685# Linux vDSO, leave for now 3686#------------------------------------------------------------------------------ 3687 { 3688 return ($FALSE); 3689 } 3690 3691# TBD: STILL NEEDED??!! 3692 3693 $loadobj_SAVE = $loadobj; 3694 3695 $blo = get_basename ($loadobj); 3696 gp_message ("debug", $subr_name, "loadobj = $loadobj"); 3697 gp_message ("debug", $subr_name, "blo = $blo"); 3698 gp_message ("debug", $subr_name, "ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME"); 3699 gp_message ("debug", $subr_name, "ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR"); 3700 if ($ARCHIVES_MAP_NAME eq $blo) 3701 { 3702 return ($ARCHIVES_MAP_VADDR); 3703 } 3704 else 3705 { 3706 return ($FALSE); 3707 } 3708 3709} #-- End of subroutine elf_phdr_sometimes 3710 3711#------------------------------------------------------------------------------ 3712# Return the virtual address for the load object. 3713# 3714# Note that at this point, $elf_arch is known to be supported. 3715#------------------------------------------------------------------------------ 3716sub elf_phdr_usual 3717{ 3718 my $subr_name = get_my_name (); 3719 3720 my ($elf_arch, $loadobj, $routine, $elf_rats_ref) = @_; 3721 3722 my %elf_rats = %{$elf_rats_ref}; 3723 3724 my $load_long_regex; 3725 $load_long_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)'; 3726 $load_long_regex .= '\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$'; 3727 my $load_short_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$'; 3728 my $re_regex = '^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$'; 3729 3730 my $return_code; 3731 my $cmd_output; 3732 my $target_cmd; 3733 my $command_string; 3734 my $error_code; 3735 my $error_code1; 3736 my $error_code2; 3737 my $msg; 3738 3739 my ($elf_offset, $loadobjARC); 3740 my ($i, @foo, $foo, $foo1, $p_vaddr, $rc); 3741 my ($Offset, $VirtAddr, $PhysAddr, $FileSiz, $MemSiz, $Flg, $Align); 3742 3743 my $arch_uname_s = $local_system_config{"kernel_name"}; 3744 3745 $msg = "elf_arch = $elf_arch loadobj = $loadobj routine = $routine"; 3746 gp_message ("debug", $subr_name, $msg); 3747 3748 my ($base, $ignore_value, $ignore_too) = fileparse ($loadobj); 3749 3750 $msg = "base = $base " . basename ($loadobj); 3751 gp_message ("debug", $subr_name, $msg); 3752 3753 if ($elf_arch eq "Linux") 3754 { 3755 if ($arch_uname_s ne $elf_arch) 3756 { 3757#------------------------------------------------------------------------------ 3758# We are masquerading between systems, must leave. 3759# Maybe we could use ELF_RATS 3760#------------------------------------------------------------------------------ 3761 $msg = "masquerading arch_uname_s->" . $arch_uname_s; 3762 $msg .= " elf_arch->" . $elf_arch; 3763 gp_message ("debug", $subr_name, $msg); 3764 3765 return ($FALSE); 3766 } 3767 if ($loadobj eq "DYNAMIC_FUNCTIONS") 3768 { 3769#------------------------------------------------------------------------------ 3770# Linux vDSO, leave for now 3771#------------------------------------------------------------------------------ 3772 gp_message ("debug", $subr_name, "early return: loadobj = $loadobj"); 3773 return ($FALSE); 3774 } 3775 3776 $target_cmd = $g_mapped_cmds{"readelf"}; 3777 $command_string = $target_cmd . " -l " . $loadobj . " 2>/dev/null"; 3778 3779 ($error_code1, $cmd_output) = execute_system_cmd ($command_string); 3780 3781 $msg = "executed command_string = " . $command_string; 3782 gp_message ("debug", $subr_name, $msg); 3783 $msg = "cmd_output = " . $cmd_output; 3784 gp_message ("debug", $subr_name, $msg); 3785 3786 if ($error_code1 != 0) 3787 { 3788 gp_message ("debug", $subr_name, "call failure for $command_string"); 3789#------------------------------------------------------------------------------ 3790# e.g. $loadobj->/usr/lib64/libc-2.17.so 3791#------------------------------------------------------------------------------ 3792 $loadobjARC = get_basename ($loadobj); 3793 gp_message ("debug", $subr_name, "seek elf_rats for $loadobjARC"); 3794 3795 if (exists ($elf_rats{$loadobjARC})) 3796 { 3797 my $elfoid; 3798 $elfoid = $elf_rats{$loadobjARC}[1] . "/archives/"; 3799 $elfoid .= $elf_rats{$loadobjARC}[0]; 3800 $target_cmd = $g_mapped_cmds{"readelf"}; 3801 $command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null"; 3802 ($error_code2, $cmd_output) = 3803 execute_system_cmd ($command_string); 3804 3805 if ($error_code2 != 0) 3806 { 3807 $msg = "call failure for " . $command_string; 3808 gp_message ("error", $subr_name, $msg); 3809 $g_total_error_count++; 3810 gp_message ("abort", $subr_name, $g_abort_msg); 3811 } 3812 else 3813 { 3814 $msg = "executed command_string = " . $command_string; 3815 gp_message ("debug", $subr_name, $msg); 3816 $msg = "cmd_output = " . $cmd_output; 3817 gp_message ("debug", $subr_name, $msg); 3818 } 3819 } 3820 else 3821 { 3822 $msg = "elf_rats{$loadobjARC} does not exist"; 3823 gp_message ("assertion", $subr_name, $msg); 3824 } 3825 } 3826#------------------------------------------------------------------------------ 3827# Example output of "readelf -l" on Linux: 3828# 3829# Elf file type is EXEC (Executable file) 3830# Entry point 0x4023a0 3831# There are 11 program headers, starting at offset 64 3832# 3833# Program Headers: 3834# Type Offset VirtAddr PhysAddr 3835# FileSiz MemSiz Flags Align 3836# PHDR 0x0000000000000040 0x0000000000400040 0x0000000000400040 3837# 0x0000000000000268 0x0000000000000268 R 8 3838# INTERP 0x00000000000002a8 0x00000000004002a8 0x00000000004002a8 3839# 0x000000000000001c 0x000000000000001c R 1 3840# [Requesting program interpreter: /lib64/ld-linux-x86-64.so.2] 3841# LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000 3842# 0x0000000000001310 0x0000000000001310 R 1000 3843# LOAD 0x0000000000002000 0x0000000000402000 0x0000000000402000 3844# 0x0000000000006515 0x0000000000006515 R E 1000 3845# LOAD 0x0000000000009000 0x0000000000409000 0x0000000000409000 3846# 0x000000000006f5a8 0x000000000006f5a8 R 1000 3847# LOAD 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8 3848# 0x000000000000047c 0x0000000000000f80 RW 1000 3849# DYNAMIC 0x0000000000078dd8 0x0000000000479dd8 0x0000000000479dd8 3850# 0x0000000000000220 0x0000000000000220 RW 8 3851# NOTE 0x00000000000002c4 0x00000000004002c4 0x00000000004002c4 3852# 0x0000000000000044 0x0000000000000044 R 4 3853# GNU_EH_FRAME 0x00000000000777f4 0x00000000004777f4 0x00000000004777f4 3854# 0x000000000000020c 0x000000000000020c R 4 3855# GNU_STACK 0x0000000000000000 0x0000000000000000 0x0000000000000000 3856# 0x0000000000000000 0x0000000000000000 RW 10 3857# GNU_RELRO 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8 3858# 0x0000000000000238 0x0000000000000238 R 1 3859# 3860# Section to Segment mapping: 3861# Segment Sections... 3862# 00 3863# 01 .interp 3864# 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym 3865# .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt 3866# 03 .init .plt .text .fini 3867# 04 .rodata .eh_frame_hdr .eh_frame 3868# 05 .init_array .fini_array .dynamic .got .got.plt .data .bss 3869# 06 .dynamic 3870# 07 .note.gnu.build-id .note.ABI-tag 3871# 08 .eh_frame_hdr 3872# 09 3873# 10 .init_array .fini_array .dynamic .got 3874#------------------------------------------------------------------------------ 3875 3876#------------------------------------------------------------------------------ 3877# Analyze the ELF information and try to find the virtual address. 3878# 3879# Note that the information printed as part of LOAD needs to have "R E" in it. 3880# In the example output above, the return value would be "0x0000000000402000". 3881# 3882# We also need to distinguish two cases. It could be that the output is on 3883# a single line, or spread over two lines: 3884# 3885# Offset VirtAddr PhysAddr FileSiz MemSiz Flg Align 3886# LOAD 0x000000 0x08048000 0x08048000 0x61b4ae 0x61b4ae R E 0x1000 3887# or 2 lines 3888# LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000 3889# 0x0000000000001010 0x0000000000001010 R E 200000 3890#------------------------------------------------------------------------------ 3891 @foo = split ("\n",$cmd_output); 3892 for $i (0 .. $#foo) 3893 { 3894 $foo = $foo[$i]; 3895 chomp ($foo); 3896 if ($foo =~ /$load_long_regex/) 3897 { 3898 $Offset = $1; 3899 $VirtAddr = $2; 3900 $PhysAddr = $3; 3901 $FileSiz = $4; 3902 $MemSiz = $5; 3903 $Flg = $6; 3904 $Align = $7; 3905 3906 $elf_offset = $VirtAddr; 3907 $msg = "single line version elf_offset = " . $elf_offset; 3908 gp_message ("debug", $subr_name, $msg); 3909 return ($elf_offset); 3910 } 3911 elsif ($foo =~ /$load_short_regex/) 3912 { 3913#------------------------------------------------------------------------------ 3914# is it a two line version? 3915#------------------------------------------------------------------------------ 3916 $Offset = $1; 3917 $VirtAddr = $2; # maybe 3918 $PhysAddr = $3; 3919 if ($i != $#foo) 3920 { 3921 $foo1 = $foo[$i + 1]; 3922 chomp ($foo1); 3923 if ($foo1 =~ /$re_regex/) 3924 { 3925 $FileSiz = $1; 3926 $MemSiz = $2; 3927 $Flg = $3; 3928 $Align = $4; 3929 $elf_offset = $VirtAddr; 3930 $msg = "two line version elf_offset = " . $elf_offset; 3931 gp_message ("debug", $subr_name, $msg); 3932 return ($elf_offset); 3933 } 3934 } 3935 } 3936 } 3937 } 3938 3939} #-- End of subroutine elf_phdr_usual 3940 3941#------------------------------------------------------------------------------ 3942# Execute a system command. In case of an error, a non-zero error code is 3943# returned. It is upon the caller to decide what to do next. 3944#------------------------------------------------------------------------------ 3945sub execute_system_cmd 3946{ 3947 my $subr_name = get_my_name (); 3948 3949 my ($target_cmd) = @_; 3950 3951 my $cmd_output; 3952 my $error_code; 3953 my $msg; 3954 3955 chomp ($target_cmd); 3956 3957 $cmd_output = qx ($target_cmd); 3958 $error_code = ${^CHILD_ERROR_NATIVE}; 3959 3960 if ($error_code != 0) 3961 { 3962 chomp ($cmd_output); 3963 $msg = "failure executing command " . $target_cmd; 3964 gp_message ("error", $subr_name, $msg); 3965 $msg = "error code = " . $error_code; 3966 gp_message ("error", $subr_name, $msg); 3967 $msg = "cmd_output = " . $cmd_output; 3968 3969 gp_message ("error", $subr_name, $msg); 3970 $g_total_error_count++; 3971 } 3972 else 3973 { 3974 $msg = "executed command " . $target_cmd; 3975 gp_message ("debugXL", $subr_name, $msg); 3976 } 3977 3978 return ($error_code, $cmd_output); 3979 3980} #-- End of subroutine execute_system_cmd 3981 3982#------------------------------------------------------------------------------ 3983# Scan the input file, which should be a gprofng generated map.xml file, and 3984# extract the relevant information. 3985#------------------------------------------------------------------------------ 3986sub extract_info_from_map_xml 3987{ 3988 my $subr_name = get_my_name (); 3989 3990 my ($input_map_xml_file) = @_; 3991 3992 my $map_xml_regex; 3993 $map_xml_regex = '<event kind="map"\s.*'; 3994 $map_xml_regex .= 'vaddr="0x([0-9a-fA-F]+)"\s+.*'; 3995 $map_xml_regex .= 'foffset="\+*0x([0-9a-fA-F]+)"\s.*'; 3996 $map_xml_regex .= 'modes="0x([0-9]+)"\s.*'; 3997 $map_xml_regex .= 'name="(.*)".*>$'; 3998 3999 my $extracted_information; 4000 my $input_line; 4001 my $vaddr; 4002 my $foffset; 4003 my $msg; 4004 my $modes; 4005 my $name_path; 4006 my $name; 4007 4008 my $full_path_exec; 4009 my $executable_name; 4010 my $result_VA; 4011 my $va_executable_in_hex; 4012 4013 $msg = " - unable to open file $input_map_xml_file for reading:"; 4014 open (MAP_XML, "<", $input_map_xml_file) 4015 or die ($subr_name . $msg . " " . $!); 4016 4017 $msg = "opened file $input_map_xml_file for reading"; 4018 gp_message ("debug", $subr_name, $msg); 4019 4020#------------------------------------------------------------------------------ 4021# Scan the file. We need to find the name of the executable with the mode set 4022# to 0x005. For this entry we have to capture the name, the mode, the virtual 4023# address and the offset. 4024#------------------------------------------------------------------------------ 4025 $extracted_information = $FALSE; 4026 while (<MAP_XML>) 4027 { 4028 $input_line = $_; 4029 chomp ($input_line); 4030 4031 $msg = "read input_line = $input_line"; 4032 gp_message ("debug", $subr_name, $msg); 4033 4034 if ($input_line =~ /^$map_xml_regex/) 4035 { 4036 $msg = "target line = $input_line"; 4037 gp_message ("debug", $subr_name, $msg); 4038 4039 $vaddr = $1; 4040 $foffset = $2; 4041 $modes = $3; 4042 $name_path = $4; 4043 $name = get_basename ($name_path); 4044 4045 $msg = "extracted vaddr = $vaddr foffset = $foffset"; 4046 $msg .= " modes = $modes"; 4047 gp_message ("debug", $subr_name, $msg); 4048 4049 $msg = "extracted name_path = $name_path name = $name"; 4050 gp_message ("debug", $subr_name, $msg); 4051 4052#------------------------------------------------------------------------------ 4053# The base virtual address is calculated as vaddr-foffset. Although Perl 4054# handles arithmetic in hex, we take the safe way here. Maybe overkill, but 4055# I prefer to be safe than sorry in cases like this. 4056#------------------------------------------------------------------------------ 4057 $full_path_exec = $name_path; 4058 $executable_name = $name; 4059 $result_VA = bigint::hex ($vaddr) - bigint::hex ($foffset); 4060 $va_executable_in_hex = sprintf ("0x%016x", $result_VA); 4061 4062## $ARCHIVES_MAP_NAME = $name; 4063## $ARCHIVES_MAP_VADDR = $va_executable_in_hex; 4064 4065 $msg = "result_VA = $result_VA"; 4066 gp_message ("debug", $subr_name, $msg); 4067 4068 $msg = "va_executable_in_hex = $va_executable_in_hex"; 4069 gp_message ("debug", $subr_name, $msg); 4070 4071#------------------------------------------------------------------------------ 4072# Stop reading when we found the correct entry. 4073#------------------------------------------------------------------------------ 4074 if ($modes eq "005") 4075 { 4076 $extracted_information = $TRUE; 4077 last; 4078 } 4079 } 4080 } #-- End of while-loop 4081 4082 if (not $extracted_information) 4083 { 4084 $msg = "cannot find the necessary information in file"; 4085 $msg .= " " . $input_map_xml_file; 4086 gp_message ("assertion", $subr_name, $msg); 4087 } 4088 4089 $msg = "full_path_exec = $full_path_exec"; 4090 gp_message ("debug", $subr_name, $msg); 4091 $msg = "executable_name = $executable_name"; 4092 gp_message ("debug", $subr_name, $msg); 4093 $msg = "va_executable_in_hex = $va_executable_in_hex"; 4094 gp_message ("debug", $subr_name, $msg); 4095 4096 return ($full_path_exec, $executable_name, $va_executable_in_hex); 4097 4098} #-- End of subroutine extract_info_from_map_xml 4099 4100#------------------------------------------------------------------------------ 4101# This routine analyzes the metric line and extracts the metric specifics 4102# from it. 4103# Example input: Exclusive Total CPU Time: e.%totalcpu 4104#------------------------------------------------------------------------------ 4105sub extract_metric_specifics 4106{ 4107 my $subr_name = get_my_name (); 4108 4109 my ($metric_line) = @_; 4110 4111 my $metric_description; 4112 my $metric_flavor; 4113 my $metric_visibility; 4114 my $metric_name; 4115 my $metric_spec; 4116 4117# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){ 4118 if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/)) 4119 { 4120 gp_message ("debug", $subr_name, "line of interest: $metric_line"); 4121 4122 $metric_description = $1; 4123 $metric_flavor = $2; 4124 $metric_visibility = $3; 4125 $metric_name = $4; 4126 4127#------------------------------------------------------------------------------ 4128# Although we have captured the metric visibility, the original code removes 4129# this from the name. Since the structure is more complicated, the code is 4130# more tedious as well. With our new approach we just leave the visibility 4131# out. 4132#------------------------------------------------------------------------------ 4133# $metric_spec = $metric_flavor.$metric_visibility.$metric_name; 4134 4135 $metric_spec = $metric_flavor . "." . $metric_name; 4136 4137#------------------------------------------------------------------------------ 4138# From the original code: 4139# 4140# On x64 systems there are metrics which contain ~ (for example 4141# DC_access~umask=0 . When er_print lists them, they come out 4142# as DC_access%7e%umask=0 (see 6530691). Untill 6530691 is 4143# fixed, we need this. Later we may need something else, or 4144# things may just work. 4145#------------------------------------------------------------------------------ 4146# $metric_spec=~s/\%7e\%/,/; 4147# # remove % metric 4148# print "DB: before \$metric_spec = $metric_spec\n"; 4149 4150#------------------------------------------------------------------------------ 4151# TBD: I don't know why the "%" symbol is removed. 4152#------------------------------------------------------------------------------ 4153# $metric_spec =~ s/\%//; 4154# print "DB: after \$metric_spec = $metric_spec\n"; 4155 4156 return ($metric_spec, $metric_flavor, $metric_visibility, 4157 $metric_name, $metric_description); 4158 } 4159 else 4160 { 4161 return ("skipped", "void"); 4162 } 4163 4164} #-- End of subroutine extract_metric_specifics 4165 4166#------------------------------------------------------------------------------ 4167# Extract the option value(s) from the input array. In case the number of 4168# values execeeds the specified limit, warning messages are printed. 4169# 4170# In case the option value is valid, g_user_settings is updated with this 4171# value and a value of TRUE is returned. Otherwise the return value is FALSE. 4172# 4173# Note that not in all invocations of this subroutine, gp_message() is 4174# operational. Only after the debug settings have been finalized, the 4175# messages are printed. 4176# 4177# This subroutine also generates warnings about multiple occurrences 4178# and the validity of the values. 4179#------------------------------------------------------------------------------ 4180sub extract_option_value 4181{ 4182 my $subr_name = get_my_name (); 4183 4184 my ($option_dir_ref, $max_occurrences_ref, $internal_option_name_ref, 4185 $option_name_ref) = @_; 4186 4187 my @option_dir = @{ $option_dir_ref }; 4188 my $max_occurrences = ${ $max_occurrences_ref }; 4189 my $internal_option_name = ${ $internal_option_name_ref }; 4190 my $option_name = ${ $option_name_ref }; 4191 4192 my $deprecated_option_used; 4193 my $excess_occurrences; 4194 my $msg; 4195 my $no_of_occurrences; 4196 my $no_of_warnings = 0; 4197 my $option_value = "not set yet"; 4198 my $option_value_missing; 4199 my $option_value_missing_ref; 4200 my $reset_blank_value; 4201 my $special_treatment = $FALSE; 4202 my $valid = $FALSE; 4203 my $valid_ref; 4204 4205 if (@option_dir) 4206 { 4207 $no_of_occurrences = scalar (@option_dir); 4208 4209 $msg = "option_name = $option_name"; 4210 gp_message ("debug", $subr_name, $msg); 4211 $msg = "internal_option_name = $internal_option_name"; 4212 gp_message ("debug", $subr_name, $msg); 4213 $msg = "no_of_occurrences = $no_of_occurrences"; 4214 gp_message ("debug", $subr_name, $msg); 4215 4216 $excess_occurrences = ($no_of_occurrences > $max_occurrences) ? 4217 $TRUE : $FALSE; 4218 4219#------------------------------------------------------------------------------ 4220# This is not supposed to happen, but just to be sure, there is a check. 4221#------------------------------------------------------------------------------ 4222 if ($no_of_occurrences < 1) 4223 { 4224 $msg = "the number of fields is $no_of_occurrences"; 4225 $msg .= " - should at least be 1"; 4226 gp_message ("assertion", $subr_name, $msg); 4227 } 4228 4229#------------------------------------------------------------------------------ 4230# For backward compatibility, we support the legacy "on" and "off" values for 4231# certain options. 4232# 4233# We also support the debug option without value. In case no value is given, 4234# it is set to "on". 4235# 4236# Note that regardless of the value(s) in ARGV, internally we use the on/off 4237# setting. 4238#------------------------------------------------------------------------------ 4239 if (($g_user_settings{$internal_option_name}{"data_type"} eq "onoff") or 4240 ($internal_option_name eq "debug")) 4241 { 4242 $msg = "enable special treatment of the option"; 4243 gp_message ("debug", $subr_name, $msg); 4244 4245 $special_treatment = $TRUE; 4246 } 4247 4248#------------------------------------------------------------------------------ 4249# Issue a warning if the same option occcurs more often than what is supported. 4250#------------------------------------------------------------------------------ 4251 if ($excess_occurrences) 4252 { 4253 $msg = "multiple occurrences of the " . $option_name . 4254 " option found:"; 4255 4256 gp_message ("debugM", $subr_name, $msg); 4257 4258 gp_message ("warning", $subr_name, $g_html_new_line . $msg); 4259 } 4260 4261#------------------------------------------------------------------------------ 4262# Main loop over all the occurrences of the options. This is a rather simple 4263# approach since only the last value seen will be accepted. 4264# 4265# To assist the user with troubleshooting, the values that are ignored will be 4266# checked for validity and a marker to this extent will be printed. 4267# 4268# NOTE: 4269# If an option may have multiple meaningful occurrences, this part needs to be 4270# revisited. 4271#------------------------------------------------------------------------------ 4272 $deprecated_option_used = $FALSE; 4273 for my $key (keys @option_dir) 4274 { 4275 $option_value = $option_dir[$key]; 4276 $reset_blank_value = $FALSE; 4277 4278#------------------------------------------------------------------------------ 4279# For the "onoff" options, convert a blank value to "on". 4280#------------------------------------------------------------------------------ 4281 if (($option_value eq "on") or ($option_value eq "off")) 4282 { 4283 if (($option_name eq "--verbose") or ($option_name eq "--quiet")) 4284 { 4285 $deprecated_option_used = $TRUE; 4286 } 4287 } 4288 4289#------------------------------------------------------------------------------ 4290# For the "onoff" options, convert a blank value to "on". 4291#------------------------------------------------------------------------------ 4292 if ($special_treatment and ($option_value eq "")) 4293 { 4294 $option_value = "on"; 4295 $reset_blank_value = $TRUE; 4296 4297 $msg = "reset option value for $option_name from blank"; 4298 $msg .= " to \"on\""; 4299 gp_message ("debug", $subr_name, $msg); 4300 } 4301 4302#------------------------------------------------------------------------------ 4303# Check for the option value to be valid. It may also happen that an option 4304# does not have a value, while it should have one. 4305#------------------------------------------------------------------------------ 4306 ($valid_ref, $option_value_missing_ref) = check_and_set_user_option ( 4307 $internal_option_name, 4308 $option_value); 4309 4310 $valid = ${ $valid_ref }; 4311 $option_value_missing = ${ $option_value_missing_ref }; 4312 4313 $msg = "option_value = $option_value"; 4314 gp_message ("debug", $subr_name, $msg); 4315 $msg = "after check_and_set_user_option: valid = $valid"; 4316 $msg .= " option_value_missing = $option_value_missing"; 4317 gp_message ("debug", $subr_name, $msg); 4318 4319#------------------------------------------------------------------------------ 4320# Generate warning messages, but if an option value is missing, it will also 4321# be considered to be a fatal error. 4322#------------------------------------------------------------------------------ 4323 if ($excess_occurrences) 4324 { 4325 if ($option_value_missing) 4326 { 4327 $msg = "$option_name option - missing a value"; 4328 } 4329 else 4330 { 4331#------------------------------------------------------------------------------ 4332# A little trick to avoid user confusion. Although we have set the internal 4333# value to "on", the user did not set this and so we print "" instead. 4334#------------------------------------------------------------------------------ 4335 if ($reset_blank_value) 4336 { 4337 $msg = "$option_name option - value = \"\""; 4338 } 4339 else 4340 { 4341 $msg = "$option_name option - value = $option_value"; 4342 } 4343 $msg .= ($valid) ? " (valid value)" : " (invalid value)"; 4344 } 4345 4346 gp_message ("debug", $subr_name, $msg); 4347 gp_message ("warning", $subr_name, $msg); 4348 } 4349 4350#------------------------------------------------------------------------------ 4351# Check for the last occurrence of the option to be valid. If it is not, it 4352# is a fatal error. 4353#------------------------------------------------------------------------------ 4354 if ((not $valid) && ($key == $no_of_occurrences-1)) 4355 { 4356 if ($option_value_missing) 4357 { 4358 $msg = "the $option_name option requires a value"; 4359 } 4360 else 4361 { 4362 $msg = "the value of $option_value for the $option_name"; 4363 $msg .= " option is invalid"; 4364 } 4365 gp_message ("debug", $subr_name, $g_error_keyword . $msg); 4366 4367 gp_message ("error", $subr_name, $msg); 4368 4369 $g_total_error_count++; 4370 } 4371 } 4372 4373#------------------------------------------------------------------------------ 4374# Issue a warning if the same option occcurs more often than what is supported 4375# and warn the user that all but the last value will be ignored. 4376#------------------------------------------------------------------------------ 4377 if ($excess_occurrences) 4378 { 4379 $msg = "all values but the last one shown above are ignored"; 4380 4381 gp_message ("debugM", $subr_name, $msg); 4382 gp_message ("warning", $subr_name, $msg); 4383 4384 $g_total_warning_count++; 4385 } 4386 } 4387 4388#------------------------------------------------------------------------------ 4389# Issue a warning if the old on/off syntax is used still. 4390#------------------------------------------------------------------------------ 4391 if ($deprecated_option_used) 4392 { 4393 $msg = "<br>"; 4394 $msg .= "the on/off syntax for option $option_name has been"; 4395 $msg .= " deprecated"; 4396 gp_message ("warning", $subr_name, $msg); 4397 4398 $msg = "this option acts like a switch now"; 4399 gp_message ("warning", $subr_name, $msg); 4400 4401 $msg = "support for the old syntax may be terminated"; 4402 $msg .= " in a future update"; 4403 gp_message ("warning", $subr_name, $msg); 4404 4405 $msg = "please check the man page of gp-display-html"; 4406 $msg .= " for more details"; 4407 gp_message ("warning", $subr_name, $msg); 4408 $g_total_warning_count++; 4409 } 4410 4411 return (\$valid); 4412 4413} #-- End of subroutine extract_option_value 4414 4415#------------------------------------------------------------------------------ 4416# TBD 4417#------------------------------------------------------------------------------ 4418sub extract_source_line_number 4419{ 4420 my $subr_name = get_my_name (); 4421 4422 my ($src_times_regex, $function_regex, $number_of_metrics, $input_line) = @_; 4423 4424#------------------------------------------------------------------------------ 4425# The regex section. 4426#------------------------------------------------------------------------------ 4427 my $find_dot_regex = '\.'; 4428 4429 my @fields_in_line = (); 4430 my $hot_line; 4431 my $line_id; 4432 4433#------------------------------------------------------------------------------ 4434# To extract the source line number, we need to distinguish whether this is 4435# a line with, or without metrics. 4436#------------------------------------------------------------------------------ 4437 @fields_in_line = split (" ", $input_line); 4438 if ( $input_line =~ /$src_times_regex/ ) 4439 { 4440 $hot_line = $1; 4441 if ($hot_line eq "##") 4442#------------------------------------------------------------------------------ 4443# The line id comes after the "##" symbol and the metrics. 4444#------------------------------------------------------------------------------ 4445 { 4446 $line_id = $fields_in_line[$number_of_metrics+1]; 4447 } 4448 else 4449#------------------------------------------------------------------------------ 4450# The line id comes after the metrics. 4451#------------------------------------------------------------------------------ 4452 { 4453 $line_id = $fields_in_line[$number_of_metrics]; 4454 } 4455 } 4456 elsif ($input_line =~ /$function_regex/) 4457 { 4458 $line_id = "func"; 4459 } 4460 else 4461#------------------------------------------------------------------------------ 4462# The line id is the first non-blank element. 4463#------------------------------------------------------------------------------ 4464 { 4465 $line_id = $fields_in_line[0]; 4466 } 4467#------------------------------------------------------------------------------ 4468# Remove the trailing dot. 4469#------------------------------------------------------------------------------ 4470 $line_id =~ s/$find_dot_regex//; 4471 4472 return ($line_id); 4473 4474} #-- End of subroutine extract_source_line_number 4475 4476#------------------------------------------------------------------------------ 4477# Finalize the settings for the special options verbose, debug, warnings and 4478# quiet. 4479#------------------------------------------------------------------------------ 4480sub finalize_special_options 4481{ 4482 my $subr_name = get_my_name (); 4483 4484 my $msg; 4485 4486#------------------------------------------------------------------------------ 4487# If quiet mode has been enabled, disable verbose, warnings and debug. 4488#------------------------------------------------------------------------------ 4489 if ($g_quiet) 4490 { 4491 $g_user_settings{"verbose"}{"current_value"} = "off"; 4492 $g_user_settings{"nowarnings"}{"current_value"} = "on"; 4493 $g_user_settings{"warnings"}{"current_value"} = "off"; 4494 $g_user_settings{"debug"}{"current_value"} = "off"; 4495 $g_debug = $FALSE; 4496 $g_verbose = $FALSE; 4497 $g_warnings = $FALSE; 4498 my $debug_off = "off"; 4499 my $ignore_value = set_debug_size (\$debug_off); 4500 } 4501 else 4502 { 4503#------------------------------------------------------------------------------ 4504# Disable output buffering if verbose, debug, and/or warnings are enabled. 4505#------------------------------------------------------------------------------ 4506 if ($g_verbose or $g_debug or $g_warnings) 4507 { 4508 STDOUT->autoflush (1); 4509 4510 $msg = "enabled autoflush for STDOUT"; 4511 gp_message ("debug", $subr_name, $msg); 4512 } 4513#------------------------------------------------------------------------------ 4514# If verbose and/or debug have been enabled, print a message. 4515#------------------------------------------------------------------------------ 4516## gp_message ("verbose", $subr_name, "verbose mode has been enabled"); 4517## gp_message ("debug", $subr_name, "debug " . $g_debug_size_value . " mode has been enabled"); 4518 } 4519 4520 return (0); 4521 4522} #-- End of subroutine finalize_special_options 4523 4524#------------------------------------------------------------------------------ 4525# For a give routine name and address, find the index into the 4526# function_info array 4527#------------------------------------------------------------------------------ 4528sub find_index_in_function_info 4529{ 4530 my $subr_name = get_my_name (); 4531 4532 my ($routine_ref, $current_address_ref, $function_info_ref) = @_; 4533 4534 my $routine = ${ $routine_ref }; 4535 my $current_address = ${ $current_address_ref }; 4536 my @function_info = @{ $function_info_ref }; 4537 4538 my $addr_offset; 4539 my $ref_index; 4540 4541 gp_message ("debugXL", $subr_name, "find index for routine = $routine and current_address = $current_address"); 4542 if (exists ($g_multi_count_function{$routine})) 4543 { 4544 4545# TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!! 4546 4547 gp_message ("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); 4548 for my $ref (keys @{ $g_map_function_to_index{$routine} }) 4549 { 4550 $ref_index = $g_map_function_to_index{$routine}[$ref]; 4551 4552 gp_message ("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); 4553 gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); 4554 4555 $addr_offset = $function_info[$ref_index]{"addressobjtext"}; 4556 gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); 4557 4558 $addr_offset =~ s/^@\d+://; 4559 gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); 4560 if ($addr_offset eq $current_address) 4561 { 4562 last; 4563 } 4564 } 4565 } 4566 else 4567 { 4568#------------------------------------------------------------------------------ 4569# There is only a single occurrence and it is straightforward to get the index. 4570#------------------------------------------------------------------------------ 4571 if (exists ($g_map_function_to_index{$routine})) 4572 { 4573 $ref_index = $g_map_function_to_index{$routine}[0]; 4574 } 4575 else 4576 { 4577 my $msg = "index for $routine cannot be determined"; 4578 gp_message ("assertion", $subr_name, $msg); 4579 } 4580 } 4581 4582 gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address ref_index = $ref_index"); 4583 4584 return (\$ref_index); 4585 4586} #-- End of subroutine find_index_in_function_info 4587 4588#------------------------------------------------------------------------------ 4589# TBD 4590#------------------------------------------------------------------------------ 4591sub find_keyword_in_string 4592{ 4593 my $subr_name = get_my_name (); 4594 4595 my ($target_string_ref, $target_keyword_ref) = @_; 4596 4597 my $target_string = ${ $target_string_ref }; 4598 my $target_keyword = ${ $target_keyword_ref }; 4599 my $foundit = $FALSE; 4600 4601 my @index_values = (); 4602 4603 my $ret_val = 0; 4604 my $offset = 0; 4605 gp_message ("debugXL", $subr_name, "target_string = $target_string"); 4606 $ret_val = index ($target_string, $target_keyword, $offset); 4607 gp_message ("debugXL", $subr_name, "ret_val = $ret_val"); 4608 4609 if ($ret_val != -1) 4610 { 4611 $foundit = $TRUE; 4612 while ($ret_val != -1) 4613 { 4614 push (@index_values, $ret_val); 4615 $offset = $ret_val + 1; 4616 gp_message ("debugXL", $subr_name, "ret_val = $ret_val offset = $offset"); 4617 $ret_val = index ($target_string, $target_keyword, $offset); 4618 } 4619 for my $i (keys @index_values) 4620 { 4621 gp_message ("debugXL", $subr_name, "index_values[$i] = $index_values[$i]"); 4622 } 4623 } 4624 else 4625 { 4626 gp_message ("debugXL", $subr_name, "target keyword $target_keyword not found"); 4627 } 4628 4629 return (\$foundit, \@index_values); 4630 4631} #-- End of subroutine find_keyword_in_string 4632 4633#------------------------------------------------------------------------------ 4634# Retrieve the absolute path that was used to execute the command. This path 4635# is used to execute gp-display-text later on. 4636#------------------------------------------------------------------------------ 4637sub find_path_to_gp_display_text 4638{ 4639 my $subr_name = get_my_name (); 4640 4641 my ($full_command_ref) = @_; 4642 4643 my $full_command = ${ $full_command_ref }; 4644 4645 my $error_occurred = $TRUE; 4646 my $return_value; 4647 4648#------------------------------------------------------------------------------ 4649# Get the path name. 4650#------------------------------------------------------------------------------ 4651 my ($gp_file_name, $gp_path, $suffix_not_used) = fileparse ($full_command); 4652 4653 gp_message ("debug", $subr_name, "full_command = $full_command"); 4654 gp_message ("debug", $subr_name, "gp_path = $gp_path"); 4655 4656 my $gp_display_text_instance = $gp_path . $GP_DISPLAY_TEXT; 4657 4658#------------------------------------------------------------------------------ 4659# Check if $GP_DISPLAY_TEXT exists, is not empty, and executable. 4660#------------------------------------------------------------------------------ 4661 if (not -e $gp_display_text_instance) 4662 { 4663 $return_value = "file not found"; 4664 } 4665 else 4666 { 4667 if (is_file_empty ($gp_display_text_instance)) 4668 { 4669 $return_value = "file is empty"; 4670 } 4671 else 4672 { 4673#------------------------------------------------------------------------------ 4674# All is well. Capture the path. 4675#------------------------------------------------------------------------------ 4676 $error_occurred = $FALSE; 4677 $return_value = $gp_path; 4678 } 4679 } 4680 4681 return (\$error_occurred, \$gp_path, \$return_value); 4682 4683} #-- End of subroutine find_path_to_gp_display_text 4684 4685#------------------------------------------------------------------------------ 4686# Scan the command line to see if the specified option is present. 4687# 4688# Two types of options are supported: options without a value (e.g. --help) or 4689# those that are set to "on" or "off". 4690# 4691# In this phase, we only need to check if a value is valid. If it is, we have 4692# to enable the corresponding global setting. If the value is not valid, we 4693# ignore it, since it will be caught later and a warning message is issued. 4694#------------------------------------------------------------------------------ 4695sub find_target_option 4696{ 4697 my $subr_name = get_my_name (); 4698 4699 my ($command_line_ref, $option_requires_value, $target_option) = @_; 4700 4701 my @command_line = @{ $command_line_ref }; 4702 my $option_value = undef; 4703 my $found_option = $FALSE; 4704 4705 my ($command_line_string) = join (" ", @command_line); 4706 4707## if ($command_line_string =~ /\s*($target_option)\s*(on|off)*\s*/) 4708#------------------------------------------------------------------------------ 4709# This does not make any assumptions on the values we are looking for. 4710#------------------------------------------------------------------------------ 4711 if ($command_line_string =~ /\s*\-\-($target_option)\s*(\w*)\s*/) 4712 { 4713 if (defined ($1)) 4714#------------------------------------------------------------------------------ 4715# We have found the option we are looking for. 4716#------------------------------------------------------------------------------ 4717 { 4718 $found_option = $TRUE; 4719 if ($option_requires_value and defined ($2)) 4720#------------------------------------------------------------------------------ 4721# There is a value and it is passed on to the caller. 4722#------------------------------------------------------------------------------ 4723 { 4724 $option_value = $2; 4725 } 4726 } 4727 } 4728 4729 return ($found_option, $option_value); 4730 4731} #-- End of subroutine find_target_option 4732 4733#------------------------------------------------------------------------------ 4734# Find the occurrences of non-space characters in a string and return their 4735# start and end index values(s). 4736#------------------------------------------------------------------------------ 4737sub find_words_in_line 4738{ 4739 my $subr_name = get_my_name (); 4740 4741 my ($input_line_ref) = @_; 4742 4743 my $input_line = ${ $input_line_ref }; 4744 4745 my $finished = $TRUE; 4746 4747 my $space = 0; 4748 my $space_position = 0; 4749 my $start_word; 4750 my $end_word; 4751 4752 my @word_delimiters = (); 4753 4754 gp_message ("debugXL", $subr_name, "input_line = $input_line"); 4755 4756 $finished = $FALSE; 4757 while (not $finished) 4758 { 4759 $space = index ($input_line, " ", $space_position); 4760 4761 my $txt = "string search space_position = $space_position "; 4762 $txt .= "space = $space"; 4763 gp_message ("debugXL", $subr_name, $txt); 4764 4765 if ($space != -1) 4766 { 4767 if ($space > $space_position) 4768 { 4769 $start_word = $space_position; 4770 $end_word = $space - 1; 4771 $space_position = $space; 4772 my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); 4773 gp_message ("debugXL", $subr_name, "string search start_word = $start_word end_word = $end_word space_position = $space_position $keyword"); 4774 push (@word_delimiters, [$start_word, $end_word]); 4775 } 4776 elsif ( ($space == $space_position) and ($space < length ($input_line) - 1)) 4777 { 4778 $space = $space + 1; 4779 $space_position = $space; 4780 } 4781 else 4782 { 4783 print "DONE\n"; 4784 $finished = $TRUE; 4785 gp_message ("debugXL", $subr_name, "completed - finished = $finished"); 4786 } 4787 } 4788 else 4789 { 4790 $finished = $TRUE; 4791 $start_word = $space_position; 4792 $end_word = length ($input_line) - 1; 4793 my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1); 4794 push (@word_delimiters, [$start_word, $end_word]); 4795 if ($keyword =~ /\s+/) 4796 { 4797 my $txt = "end search spaces only"; 4798 gp_message ("debugXL", $subr_name, $txt); 4799 } 4800 else 4801 { 4802 my $txt = "end search start_word = $start_word "; 4803 $txt .= "end_word = $end_word "; 4804 $txt .= "space_position = $space_position -->$keyword<--"; 4805 gp_message ("debugXL", $subr_name, $txt); 4806 } 4807 } 4808 4809 } 4810 4811 for my $i (keys @word_delimiters) 4812 { 4813 gp_message ("debugXL", $subr_name, "i = $i $word_delimiters[$i][0] $word_delimiters[$i][1]"); 4814 } 4815 4816 return (\@word_delimiters); 4817 4818} #-- End of subroutine find_words_in_line 4819 4820#------------------------------------------------------------------------------ 4821# TBD 4822#------------------------------------------------------------------------------ 4823sub function_info 4824{ 4825 my $subr_name = get_my_name (); 4826 4827 my ($outputdir, $FUNC_FILE, $metric, $LINUX_vDSO_ref) = @_; 4828 4829 my %LINUX_vDSO = %{ $LINUX_vDSO_ref }; 4830 4831 my $index_val; 4832 my $address_decimal; 4833 my $full_address_field; 4834 4835 my $FUNC_FILE_NO_PC; 4836 my $off_with_the_PC; 4837 4838 my $blanks; 4839 my $lblanks; 4840 my $lvdso_key; 4841 my $line_regex; 4842 4843 my %functions_per_metric_indexes = (); 4844 my %functions_per_metric_first_index = (); 4845 my @order; 4846 4847 my ($line,$line_n,$value); 4848 my ($df_flag,$n,$u); 4849 my ($metric_value,$PC_Address,$routine); 4850 my ($is_calls,$metric_ok,$name_regex,$pc_len); 4851 my ($segment,$offset,$offy,$spaces,$rest,$not_printed,$vdso_key); 4852 4853#------------------------------------------------------------------------------ 4854# If the directory name does not end with a "/", add it. 4855#------------------------------------------------------------------------------ 4856 my $length_of_string = length ($outputdir); 4857 4858 if (rindex ($outputdir, "/") != $length_of_string-1) 4859 { 4860 $outputdir .= "/"; 4861 } 4862 4863 gp_message ("debug", $subr_name, "on input FUNC_FILE = $FUNC_FILE metric = $metric"); 4864 4865 $is_calls = $FALSE; 4866 $metric_ok = $TRUE; 4867 $off_with_the_PC = rindex ($FUNC_FILE, "-PC"); 4868 $FUNC_FILE_NO_PC = substr ($FUNC_FILE, 0, $off_with_the_PC); 4869 4870 if ($FUNC_FILE_NO_PC eq $outputdir."calls.sort.func") 4871 { 4872 $FUNC_FILE_NO_PC = $outputdir."calls"; 4873 $is_calls = $TRUE; 4874 $metric_ok = $FALSE; 4875 } 4876 elsif ($FUNC_FILE_NO_PC eq $outputdir."calltree.sort.func") 4877 { 4878 $FUNC_FILE_NO_PC = $outputdir."calltree"; 4879 $metric_ok = $FALSE; 4880 } 4881 elsif ($FUNC_FILE_NO_PC eq $outputdir."functions.sort.func") 4882 { 4883 $FUNC_FILE_NO_PC = $outputdir."functions.func"; 4884 $metric_ok = $FALSE; 4885 } 4886 gp_message ("debugM", $subr_name, "set FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC"); 4887 4888 open (FUNC_FILE, "<", $FUNC_FILE) 4889 or die ("Not able to open file $FUNC_FILE for reading - '$!'"); 4890 gp_message ("debug", $subr_name, "opened file FUNC_FILE = $FUNC_FILE for reading"); 4891 4892 open (FUNC_FILE_NO_PC, ">", $FUNC_FILE_NO_PC) 4893 or die ("Not able to open file $FUNC_FILE_NO_PC for writing - '$!'"); 4894 gp_message ("debug", $subr_name, "opened file FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC for writing"); 4895 4896 open (FUNC_FILE_REGEXP, "<", "$FUNC_FILE.name-regex") 4897 or die ("Not able to open file $FUNC_FILE.name-regex for reading - '$!'"); 4898 gp_message ("debug", $subr_name, "opened file FUNC_FILE_REGEXP = $FUNC_FILE.name-regex for reading"); 4899 4900 $name_regex = <FUNC_FILE_REGEXP>; 4901 chomp ($name_regex); 4902 close (FUNC_FILE_REGEXP); 4903 4904 gp_message ("debugXL", $subr_name, "name_regex = $name_regex"); 4905 4906 $n = 0; 4907 $u = 0; 4908 $pc_len = 0; 4909 4910#------------------------------------------------------------------------------ 4911# Note that the double \\ is needed here. The regex used will not have these. 4912#------------------------------------------------------------------------------ 4913 if ($is_calls) 4914 { 4915#------------------------------------------------------------------------------ 4916# TBD 4917# I do not see the "*" in my test output, but no harm to leave the code in. 4918# 4919# er_print * before PC for calls ! 101315 4920#------------------------------------------------------------------------------ 4921 $line_regex = "^(\\s*)(\\**)(\\S+)(:)(\\S+)(\\s+)(.*)"; 4922 } 4923 else 4924 { 4925 $line_regex = "^(\\s*)(\\S+)(:)(\\S+)(\\s+)(.*)"; 4926 } 4927 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." line_regex->$line_regex<-"); 4928 gp_message ("debugXL", $subr_name, "read FUNC_FILE = $FUNC_FILE"); 4929 4930 $line_n = 0; 4931 $index_val = 0; 4932 while (<FUNC_FILE>) 4933 { 4934 $line = $_; 4935 chomp ($line); 4936 $line =~ s/ -- no functions found//; 4937 4938 gp_message ("debug", $subr_name, "FUNC_FILE: input line = $line"); 4939 4940 $line_n++; 4941 if ($line =~ /$line_regex/) # field 2|3 needs to be \S in case of -ve sign 4942 { 4943#------------------------------------------------------------------------------ 4944# A typical target line looks like this: 4945# 11:0x001492e0 6976.900 <additional_timings> _lwp_start 4946#------------------------------------------------------------------------------ 4947 gp_message ("debugXL", $subr_name, "select = $line"); 4948 if ($is_calls) 4949 { 4950 $segment = $3; 4951 $offset = $5; 4952 $spaces = $6; 4953 $rest = $7; 4954 $PC_Address = $segment.$4.$offset; # PC Addr. 4955 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$3 = $3"); 4956 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); 4957 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); 4958 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$7 = $7"); 4959 } 4960 else 4961 { 4962 $segment = $2; 4963 $offset = $4; 4964 $spaces = $5; 4965 $rest = $6; 4966 $PC_Address = $segment.$3.$offset; # PC Addr. 4967 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$2 = $2"); 4968 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$4 = $4"); 4969 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$5 = $5"); 4970 gp_message ("debugXL", $subr_name, "is_calls = ".(($is_calls) ? "TRUE" : "FALSE")." \$6 = $6"); 4971 } 4972 if ($segment == -1) 4973 { 4974#------------------------------------------------------------------------------ 4975# presume vDSO field overflow - er_print used an inadequate format 4976# or the fsummary (MASTER) had the wrong format for -1? 4977# rats - get ahead of ourselves - should not be a field abuttal so 4978#------------------------------------------------------------------------------ 4979 if ($line =~ /$name_regex/) 4980 { 4981 if ($metric_ok) 4982 { 4983 $metric_value = $1; # whatever 4984 $routine = $2; 4985 } 4986 else 4987 { 4988 $routine = $1; 4989 } 4990 if ($is_calls) 4991 { 4992 if (substr ($routine,0,1) eq "*") 4993 { 4994 $routine = substr ($routine,1); 4995 } 4996 } 4997 for $vdso_key (keys %LINUX_vDSO) 4998 { 4999 if ($routine eq $LINUX_vDSO{$vdso_key}) 5000 { 5001#------------------------------------------------------------------------------ 5002# presume no duplicates - at least can check offset 5003#------------------------------------------------------------------------------ 5004 if ($vdso_key =~ /(\d+):(\S+)/) 5005#------------------------------------------------------------------------------ 5006# no -ve segments allowed and not expected 5007#------------------------------------------------------------------------------ 5008 { 5009 if ($2 eq $offset) 5010 { 5011#------------------------------------------------------------------------------ 5012# the real segment 5013#------------------------------------------------------------------------------ 5014 $segment = $1; 5015 gp_message ("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE"); 5016 $PC_Address = $segment.":".$offset; # PC Addr. 5017 gp_message ("debugXL", $subr_name, "vdso line ->$line"); 5018 $line = $PC_Address.(' ' x (length ($spaces)-2)).$rest; 5019 gp_message ("debugXL", $subr_name, "becomes ->$line"); 5020 last; 5021 } 5022 } 5023 } 5024 } 5025 } 5026 else 5027 { 5028 gp_message ("debug", $subr_name, "name_regex failure for file $FUNC_FILE"); 5029 } 5030 } 5031 5032#------------------------------------------------------------------------------ 5033# a rotten exception for Linux vDSO 5034# With a BIG "PC Address" like 32767:0x841fecd0, the functions.sort.func_PC file 5035# can have lines like 5036#->32767:0x841fecd0161.553 527182898954 131.936 100003 __vdso_gettimeofday<- 5037#->32767:0x153ff810 42.460 0 0 __vdso_gettimeofday<- 5038#->-1:0xff600000 99.040 0 0 [vsyscall]<- 5039# (Real PC Address: 4294967295:0xff600000) 5040#-> 4294967295:0xff600000 99.040 0 0 [vsyscall]<- 5041#-> 9:0x00000020 49.310 0 0 <static>@0x7fff153ff600 ([vdso])<- 5042# Rats! 5043# $LINUX_vDSO{substr($order[$i]{"addressobjtext"},1)} = $order[$i]{"routine"}; 5044#------------------------------------------------------------------------------ 5045 5046 $not_printed = $TRUE; 5047 for $vdso_key (keys %LINUX_vDSO) 5048 { 5049 if ($line =~ /^(\s*)($vdso_key)(.*)$/) 5050 { 5051 $blanks = 1; 5052 $rest = 3; 5053 $lblanks = length ($blanks); 5054 $lvdso_key = length ($vdso_key); 5055 $PC_Address = $vdso_key; # PC Addr. 5056 $offy = ($lblanks+$lvdso_key < $pc_len) ? $pc_len : $lblanks+$lvdso_key; 5057 gp_message ("debugXL", $subr_name, "offy = $offy for ->$line<-"); 5058 if ($pc_len) 5059 { 5060 print FUNC_FILE_NO_PC substr ($line,$offy)."\n"; 5061 $not_printed = $FALSE; 5062 } 5063 else 5064 { 5065 die ("sod1a"); 5066 } 5067 gp_message ("debugXL", $subr_name, "vdso line ->$line"); 5068 if (substr ($line,$lblanks+$lvdso_key,1) eq " ") 5069 { 5070#------------------------------------------------------------------------------ 5071# O.K. no field abuttal 5072#------------------------------------------------------------------------------ 5073 gp_message ("debugXL", $subr_name, "vdso no field abuttal line ->$line"); 5074 } 5075 else 5076 { 5077 gp_message ("debugXL", $subr_name, "vdso field abuttal line ->$line"); 5078 $line = $blanks.$vdso_key." ".$rest; 5079 } 5080 gp_message ("debugXL", $subr_name, "becomes ->$line"); 5081 last; 5082 } 5083 } 5084 if ($not_printed) 5085 { 5086 if ($pc_len) 5087 { 5088 print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; 5089 } 5090 else 5091 { 5092 die ("sod1b"); 5093 } 5094 $not_printed = $FALSE; 5095 } 5096 } 5097 else 5098 { 5099 if (!$pc_len) 5100 { 5101 if ($line =~ /(^\s*PC Addr.\s+)(\S+)/) 5102 { 5103 $pc_len = length ($1); # say 15 5104 print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; 5105 } 5106 else 5107 { 5108 print FUNC_FILE_NO_PC "$line\n"; 5109 } 5110 } 5111 else 5112 { 5113 if ($pc_len) 5114 { 5115 my $strlen = length ($line); 5116 if ($strlen > 0 ) 5117 { 5118 print FUNC_FILE_NO_PC substr ($line,$pc_len)."\n"; 5119 } 5120 else 5121 { 5122 print FUNC_FILE_NO_PC "\n"; 5123 } 5124 } 5125 else 5126 { 5127 die ("sod2"); 5128 } 5129 } 5130 next; 5131 } 5132 $routine = ""; 5133 if ($line =~ /$name_regex/) 5134 { 5135 if ($metric_ok) 5136 { 5137 $metric_value = $1; # whatever 5138 $routine = $2; 5139 } 5140 else 5141 { 5142 $routine = $1; 5143 } 5144 } 5145 5146 if ($is_calls) 5147 { 5148 if (substr ($routine,0,1) eq "*") 5149 { 5150 $routine = substr ($routine,1); 5151 } 5152 } 5153 if (length ($routine)) 5154 { 5155 $order[$index_val]{"routine"} = $routine; 5156 if ($metric_ok) 5157 { 5158 $order[$index_val]{"metric_value"} = $metric_value; 5159 } 5160 $order[$index_val]{"PC Address"} = $PC_Address; 5161 $df_flag = 0; 5162 if (not exists ($functions_per_metric_indexes{$routine})) 5163 { 5164 $functions_per_metric_indexes{$routine} = [$index_val]; 5165 } 5166 else 5167 { 5168 push (@{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list 5169 } 5170 gp_message ("debugXL", $subr_name, "updated functions_per_metric_indexes $routine [$index_val] line = $line"); 5171 if ($PC_Address =~ /\s*(\S+):(\S+)/) 5172 { 5173 my ($segment,$offset); 5174 $segment = $1; 5175 $offset = $2; 5176 $address_decimal = bigint::hex ($offset); # decimal 5177## $full_address_field = '@'.$segment.":".$offset; # e.g. @2:0x0003f280 5178 $full_address_field = $segment.":".$offset; # e.g. @2:0x0003f280 5179 $order[$index_val]{"addressobj"} = $address_decimal; 5180 $order[$index_val]{"addressobjtext"} = $full_address_field; 5181 } 5182#------------------------------------------------------------------------------ 5183# Check uniqueness 5184#------------------------------------------------------------------------------ 5185 if (not exists ($functions_per_metric_first_index{$routine}{$PC_Address})) 5186 { 5187 $functions_per_metric_first_index{$routine}{$PC_Address} = $index_val; 5188 $u++; #$RI 5189 } 5190 else 5191 { 5192 if (!($metric eq "calls" || $metric eq "calltree")) 5193 { 5194 gp_message ("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address"); 5195 } 5196 } 5197 5198 $index_val++; 5199 gp_message ("debugXL", $subr_name, "updated index_val = $index_val"); 5200 $n++; 5201 next; 5202 } 5203 else 5204 { 5205 if ($n && length ($line)) 5206 { 5207 my $msg = "unexpected line format in functions file $FUNC_FILE line->$line<-"; 5208 gp_message ("assertion", $subr_name, $msg); 5209 } 5210 } 5211 } 5212 close (FUNC_FILE); 5213 close (FUNC_FILE_NO_PC); 5214 5215 for my $i (sort keys %functions_per_metric_indexes) 5216 { 5217 my $values = ""; 5218 for my $fields (sort keys @{ $functions_per_metric_indexes{$i} }) 5219 { 5220 $values .= "$functions_per_metric_indexes{$i}[$fields] "; 5221 } 5222 gp_message ("debugXL", $subr_name, "on return: functions_per_metric_indexes{$i} = $values"); 5223 } 5224 5225 return (\@order, \%functions_per_metric_first_index, \%functions_per_metric_indexes); 5226 5227} #-- End of subroutine function_info 5228 5229#------------------------------------------------------------------------------ 5230# Generate a html header. 5231#------------------------------------------------------------------------------ 5232sub generate_a_header 5233{ 5234 my $subr_name = get_my_name (); 5235 5236 my ($page_text_ref, $size_text_ref, $position_text_ref) = @_; 5237 5238 my $page_text = ${ $page_text_ref }; 5239 my $size_text = ${ $size_text_ref }; 5240 my $position_text = ${ $position_text_ref }; 5241 my $html_header; 5242 5243 $html_header = "<div class=\"" . $position_text . "\">\n"; 5244 $html_header .= "<". $size_text . ">\n"; 5245 $html_header .= $page_text . "\n"; 5246 $html_header .= "</". $size_text . ">\n"; 5247 $html_header .= "</div>"; 5248 5249 gp_message ("debugXL", $subr_name, "on exit page_title = $html_header"); 5250 5251 return (\$html_header); 5252 5253} #-- End of subroutine generate_a_header 5254 5255#------------------------------------------------------------------------------ 5256# Generate the caller-callee information. 5257#------------------------------------------------------------------------------ 5258sub generate_caller_callee 5259{ 5260 my $subr_name = get_my_name (); 5261 5262 my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref, 5263 $function_address_info_ref, $addressobjtextm_ref, 5264 $input_string_ref) = @_; 5265 5266 my $number_of_metrics = ${ $number_of_metrics_ref }; 5267 my @function_info = @{ $function_info_ref }; 5268 my %function_view_structure = %{ $function_view_structure_ref }; 5269 my %function_address_info = %{ $function_address_info_ref }; 5270 my %addressobjtextm = %{ $addressobjtextm_ref }; 5271 my $input_string = ${ $input_string_ref }; 5272 5273 my @caller_callee_data = (); 5274 my $caller_callee_data_ref; 5275 my $outfile; 5276 my $input_line; 5277 5278 my $fullname; 5279 my $separator = "cuthere"; 5280 5281 my @address_field = (); 5282 my @fields = (); 5283 my @function_names = (); 5284 my @marker = (); 5285 my @metric_values = (); 5286 my @word_index_values = (); 5287 my @header_lines = (); 5288 5289 my $all_metrics; 5290 my $elements_in_name; 5291 my $full_hex_address; 5292 my $hex_address; 5293 my $msg; 5294 5295 my $remainder2; 5296 5297 my $file_title; 5298 my $page_title; 5299 my $size_text; 5300 my $position_text; 5301 my @html_metric_sort_header = (); 5302 my $html_header; 5303 my $html_title_header; 5304 my $html_home; 5305 my $html_acknowledgement; 5306 my $html_end; 5307 my $html_line; 5308 5309 my $marker_target_function; 5310 my $max_metrics_length = 0; 5311 my $metrics_length; 5312 my $modified_line; 5313 my $name_regex; 5314 my $no_of_fields; 5315 my $routine; 5316 my $routine_length; 5317 my $string_length; 5318 my $top_header; 5319 my $total_header_lines; 5320 my $word_index_values_ref; 5321 my $infile; 5322 5323 my $outputdir = append_forward_slash ($input_string); 5324 my $LANG = $g_locale_settings{"LANG"}; 5325 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 5326 5327 gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator"); 5328 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 5329 5330 $infile = $outputdir . "caller-callee-PC2"; 5331 $outfile = $outputdir . $g_html_base_file_name{"caller_callee"} . ".html"; 5332 5333 gp_message ("debug", $subr_name, "infile = $infile outfile = $outfile"); 5334 5335 open (CALLER_CALLEE_IN, "<", $infile) 5336 or die ("unable to open caller file $infile for reading - '$!'"); 5337 gp_message ("debug", $subr_name, "opened file $infile for reading"); 5338 5339 open (CALLER_CALLEE_OUT, ">", $outfile) 5340 or die ("unable to open $outfile for writing - '$!'"); 5341 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 5342 5343 $msg = "building caller-callee file " . $outfile; 5344 gp_message ("debug", $subr_name, $msg); 5345 gp_message ("verbose", $subr_name, $msg); 5346 5347#------------------------------------------------------------------------------ 5348# Generate some of the structures used in the HTML output. 5349#------------------------------------------------------------------------------ 5350 $file_title = "Caller-callee overview"; 5351 $html_header = ${ create_html_header (\$file_title) }; 5352 $html_home = ${ generate_home_link ("right") }; 5353 5354 $page_title = "Caller Callee View"; 5355 $size_text = "h2"; 5356 $position_text = "center"; 5357 $html_title_header = ${ generate_a_header (\$page_title, 5358 \$size_text, 5359 \$position_text) }; 5360 5361#------------------------------------------------------------------------------ 5362# Read all of the file into an array with the name caller_callee_data. 5363#------------------------------------------------------------------------------ 5364 chomp (@caller_callee_data = <CALLER_CALLEE_IN>); 5365 5366#------------------------------------------------------------------------------ 5367# Remove a legacy redundant string, if any. 5368#------------------------------------------------------------------------------ 5369 @caller_callee_data = @{ remove_redundant_string (\@caller_callee_data)}; 5370 5371#------------------------------------------------------------------------------ 5372# Typical structure of the input file: 5373# 5374# Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm 5375# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 5376# Functions sorted by metric: Exclusive Total CPU Time 5377# Callers and callees sorted by metric: Attributed Total CPU Time 5378# 5379# PC Addr. Name Attr. Attr. CPU Attr. Attr. 5380# Total Cycles Instructions Last-Level 5381# CPU sec. sec. Executed Cache Misses 5382# 1:0x00000000 *<Total> 3.502 4.005 15396819700 24024250 5383# 7:0x00008070 start_thread 3.342 3.865 14500538981 23824045 5384# 6:0x000233a0 __libc_start_main 0.160 0.140 896280719 200205 5385# 5386# PC Addr. Name Attr. Attr. CPU Attr. Attr. 5387# Total Cycles Instructions Last-Level 5388# CPU sec. sec. Executed Cache Misses 5389# 2:0x000021f9 driver_mxv 3.342 3.865 14500538981 23824045 5390# 2:0x000021ae *mxv_core 3.342 3.865 14500538981 23824045 5391#------------------------------------------------------------------------------ 5392 5393#------------------------------------------------------------------------------ 5394# Scan the input file. The first lines are assumed to be part of the header, 5395# so we store those. The diagnostic lines that echo some settings are also 5396# stored, but currently not used. 5397#------------------------------------------------------------------------------ 5398 my $scan_header = $FALSE; 5399 my $scan_caller_callee_data = $FALSE; 5400 my $data_function_block = ""; 5401 my @function_blocks = (); 5402 my $first = $TRUE; 5403 my @html_caller_callee = (); 5404 my @top_level_header = (); 5405 5406#------------------------------------------------------------------------------ 5407# The regexes. 5408#------------------------------------------------------------------------------ 5409 my $empty_line_regex = '^\s*$'; 5410 my $line_of_interest_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\**)(.*)'; 5411 my $get_hex_address_regex = '(\d+):0x(\S+)'; 5412 my $get_metric_field_regex = ')\s+([\s\d' . $decimal_separator . ']*)'; 5413 my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)'; 5414 my $sorted_by_regex = 'sorted by metric:'; 5415 my $current_regex = '^Current'; 5416 my $get_addr_offset_regex = '^@\d+:'; 5417 5418#------------------------------------------------------------------------------ 5419# Get the length of the first metric field across all lines. This value is 5420# used to pad the first metric with spaces and get the alignment right. 5421# 5422# Scan the input data and find the line(s) with metric values. A complication 5423# is that a function name may consists of more than one field. 5424# 5425# Note. This part could be used to parse the other elements of the input file, 5426# but that makes the loop very complicated. Instead, we re-scan the data 5427# below and process each block separately. 5428# 5429# Since this data is all in memory and relatively small, the performance should 5430# not suffer much, but it does improve the readability of the code. 5431#------------------------------------------------------------------------------ 5432 $g_max_length_first_metric = 0; 5433 5434 my @hex_addresses = (); 5435 my @metrics_array = (); 5436 my @length_first_metric = (); 5437 my @special_marker = (); 5438 my @the_function_name = (); 5439 my @the_metrics = (); 5440 5441 my $find_hex_address_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(.*)'; 5442 my $find_metric_values_regex = '\)\s+\[.*\]\s+(\d+'; 5443 $find_metric_values_regex .= '[\.\d\ ]*)|\)\s+(\d+[\.\d\ ]*)'; 5444 my $find_marker_regex = '(^\*).*'; 5445 5446 my @html_block_prologue; 5447 my @html_code_function_block; 5448 my $marker; 5449 my $list_with_metrics; 5450 my $reduced_line; 5451 5452 $msg = "loop over the caller-callee data - number of lines = "; 5453 $msg .= ($#caller_callee_data + 1); 5454 gp_message ("debugXL", $subr_name, $msg); 5455 5456 for (my $line = 0; $line <= $#caller_callee_data; $line++) 5457 { 5458 $input_line = $caller_callee_data[$line]; 5459 $reduced_line = $input_line; 5460 5461 $msg = "line = " . $line . " input_line = " . $input_line; 5462 gp_message ("debugXL", $subr_name, $msg); 5463 5464 if ($input_line =~ /$find_hex_address_regex/) 5465#------------------------------------------------------------------------------ 5466# This is an input line of interest. 5467#------------------------------------------------------------------------------ 5468 { 5469 my ($hex_address_ref, $marker_ref, $reduced_line_ref, 5470 $list_with_metrics_ref) = 5471 split_function_data_line (\$input_line); 5472 5473 $hex_address = ${ $hex_address_ref }; 5474 $marker = ${ $marker_ref }; 5475 $reduced_line = ${ $reduced_line_ref }; 5476 $list_with_metrics = ${ $list_with_metrics_ref }; 5477 5478 $msg = "RESULT full_hex_address = " . $hex_address; 5479 $msg .= " -- metric values = " . $list_with_metrics; 5480 $msg .= " -- marker = " . $marker; 5481 $msg .= " -- function name = " . $reduced_line; 5482 gp_message ("debugXL", $subr_name, $msg); 5483 5484#------------------------------------------------------------------------------ 5485# Store the address and marker. 5486#------------------------------------------------------------------------------ 5487 push (@the_function_name, $reduced_line); 5488 push (@hex_addresses, $hex_address); 5489 if ($marker eq "*") 5490 { 5491 push (@special_marker, "*"); 5492 } 5493 else 5494 { 5495 push (@special_marker, "X"); 5496 } 5497#------------------------------------------------------------------------------ 5498# Processing of the metrics. 5499#------------------------------------------------------------------------------ 5500 @metrics_array = split (" ", $list_with_metrics); 5501 5502#------------------------------------------------------------------------------ 5503# If the first metric is 0. (or 0, depending on the locale), the calculation 5504# of the length needs to be adjusted, because 0. is really 0.000. 5505# 5506# While we could easily add 3 to the length, we assign a symbolic value to the 5507# first metric (ZZZ) and then compute the length. This makes things clearer. 5508# I hope ;-) 5509#------------------------------------------------------------------------------ 5510 my $first_metric = $metrics_array[0]; 5511 $msg = "first metric found = " . $first_metric; 5512 gp_message ("debugXL", $subr_name, $msg); 5513 if ($first_metric =~ /^0$decimal_separator$/) 5514 { 5515 $first_metric = "0.ZZZ"; 5516 $msg = "fixed up $first_metric"; 5517 gp_message ("debugXL", $subr_name, $msg); 5518 } 5519 $g_max_length_first_metric = max ($g_max_length_first_metric, 5520 length ($first_metric)); 5521 5522 $msg = "first_metric = $first_metric " . 5523 "g_max_length_first_metric = $g_max_length_first_metric"; 5524 gp_message ("debugXL", $subr_name, $msg); 5525 push (@length_first_metric, length ($first_metric)); 5526 push (@the_metrics, $list_with_metrics); 5527 } 5528 } 5529 5530 $msg = "the following function names have been found"; 5531 gp_message ("debugM", $subr_name, $msg); 5532 for my $i (0 .. $#the_function_name) 5533 { 5534 $msg = "the_function_name{" . $i . "] = " . $the_function_name[$i]; 5535 gp_message ("debugM", $subr_name, $msg); 5536 } 5537 5538 $msg = "final: g_max_length_first_metric = " . $g_max_length_first_metric; 5539 gp_message ("debugM", $subr_name, $msg); 5540 $msg = "\$#hex_addresses = " . $#hex_addresses; 5541 gp_message ("debugM", $subr_name, $msg); 5542 5543#------------------------------------------------------------------------------ 5544# Main loop over the input data. 5545#------------------------------------------------------------------------------ 5546 my $index_start = 0; # 1 5547 my $index_end = -1; # 0 5548 for (my $line = 0; $line <= $#caller_callee_data; $line++) 5549 { 5550 $input_line = $caller_callee_data[$line]; 5551 5552 if ($input_line =~ /$header_name_regex/) 5553 { 5554 $scan_header = $TRUE; 5555 $msg = "line = " . $line . " encountered start of the header"; 5556 $msg .= " scan_header = " . $scan_header . " first = " . $first; 5557 gp_message ("debugXL", $subr_name, $msg); 5558 } 5559 elsif (($input_line =~ /$sorted_by_regex/) or 5560 ($input_line =~ /$current_regex/)) 5561 { 5562 $msg = "line = " . $line . " captured top level header: " . 5563 "input_line = " . $input_line; 5564 gp_message ("debugXL", $subr_name, $msg); 5565 5566 push (@top_level_header, $input_line); 5567 } 5568 elsif ($input_line =~ /$line_of_interest_regex/) 5569 { 5570 $index_end++; 5571 $scan_header = $FALSE; 5572 $scan_caller_callee_data = $TRUE; 5573 $data_function_block .= $separator . $input_line; 5574 5575 $msg = "line = $line updated index_end = $index_end"; 5576 gp_message ("debugXL", $subr_name, $msg); 5577 $msg = "line = $line input_line = " . $input_line; 5578 gp_message ("debugXL", $subr_name, $msg); 5579 $msg = "line = $line data_function_block = " . $data_function_block; 5580 gp_message ("debugXL", $subr_name, $msg); 5581 } 5582 elsif (($input_line =~ /$empty_line_regex/) and 5583 ($scan_caller_callee_data)) 5584 { 5585#------------------------------------------------------------------------------ 5586# An empty line is interpreted as the end of the current block and we process 5587# this, including the generation of the html code for this block. 5588#------------------------------------------------------------------------------ 5589 $first = $FALSE; 5590 $scan_caller_callee_data = $FALSE; 5591 5592 $msg = "new block"; 5593 gp_message ("debugXL", $subr_name, $msg); 5594 $msg = "line = " . $line . " index_start = " . $index_start; 5595 gp_message ("debugXL", $subr_name, $msg); 5596 $msg = "line = " . $line . " index_end = " . $index_end; 5597 gp_message ("debugXL", $subr_name, $msg); 5598 5599 $msg = "line = " . $line . " data_function_block = "; 5600 $msg .= $data_function_block; 5601 gp_message ("debugXL", $subr_name, $msg); 5602 5603 push (@function_blocks, $data_function_block); 5604 5605## $msg = " generating the html blocks ("; 5606## $msg .= $index_start . " - " . $index_end .")"; 5607## gp_message ("verbose", $subr_name, $msg); 5608 5609 my ($html_block_prologue_ref, $html_code_function_block_ref) = 5610 generate_html_function_blocks ( 5611 \$index_start, 5612 \$index_end, 5613 \@hex_addresses, 5614 \@the_metrics, 5615 \@length_first_metric, 5616 \@special_marker, 5617 \@the_function_name, 5618 \$separator, 5619 $number_of_metrics_ref, 5620 \$data_function_block, 5621 $function_info_ref, 5622 $function_view_structure_ref); 5623 5624 @html_block_prologue = @{ $html_block_prologue_ref }; 5625 @html_code_function_block = @{ $html_code_function_block_ref }; 5626 5627 for my $lines (0 .. $#html_code_function_block) 5628 { 5629 $msg = "final html_code_function_block[" . $lines . "] = " . 5630 $html_code_function_block[$lines]; 5631 gp_message ("debugXL", $subr_name, $msg); 5632 } 5633 5634 $data_function_block = ""; 5635 5636 push (@html_caller_callee, @html_block_prologue); 5637 push (@html_caller_callee, @header_lines); 5638 push (@html_caller_callee, @html_code_function_block); 5639 5640 $index_start = $index_end + 1; 5641 $index_end = $index_start - 1; 5642 $msg = "line = " . $line . " reset index_start = " . $index_start; 5643 gp_message ("debugXL", $subr_name, $msg); 5644 $msg = "line = " . $line . " reset index_end = " . $index_end; 5645 gp_message ("debugXL", $subr_name, $msg); 5646 } 5647 5648#------------------------------------------------------------------------------ 5649# Only capture the first header. They are all identical. 5650#------------------------------------------------------------------------------ 5651 if ($scan_header and $first) 5652 { 5653 if (defined ($4)) 5654 { 5655#------------------------------------------------------------------------------ 5656# This group is only defined for the first line of the header. 5657#------------------------------------------------------------------------------ 5658 gp_message ("debugXL", $subr_name, "header1 = $4"); 5659 gp_message ("debugXL", $subr_name, "extra = $3 spaces=x$2x"); 5660 my $newline = "<b>" . $4 . "</b>"; 5661 push (@header_lines, $newline); 5662 } 5663 elsif ($input_line =~ /\s*(.*)/) 5664 { 5665#------------------------------------------------------------------------------ 5666# Capture the subsequent header lines. 5667#------------------------------------------------------------------------------ 5668 gp_message ("debugXL", $subr_name, "headern = $1"); 5669 my $newline = "<b>" . $1 . "</b>"; 5670 push (@header_lines, $newline); 5671 } 5672 } 5673 5674 } 5675 5676 for my $i (0 .. $#header_lines) 5677 { 5678 gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]"); 5679 } 5680 for my $i (0 .. $#function_blocks) 5681 { 5682 gp_message ("debugXL", $subr_name, "function_blocks[$i] = $function_blocks[$i]"); 5683 } 5684 5685 my $number_of_blocks = $#function_blocks + 1; 5686 gp_message ("debugXL", $subr_name, "There are " . $number_of_blocks . " function blocks:"); 5687 5688 for my $i (0 .. $#function_blocks) 5689 { 5690#------------------------------------------------------------------------------ 5691# The split produces an empty first field and is why we skip the first field. 5692#------------------------------------------------------------------------------ 5693## my @entries = split ("cuthere", $function_blocks[$i]); 5694 my @entries = split ($separator, $function_blocks[$i]); 5695 for my $k (1 .. $#entries) 5696 { 5697 my $msg = "entries[" . $k . "] = ". $entries[$k]; 5698 gp_message ("debugXL", $subr_name, $k . $msg); 5699 } 5700 } 5701 5702#------------------------------------------------------------------------------ 5703# Parse and process the individual function blocks. 5704#------------------------------------------------------------------------------ 5705 $msg = "Parse and process function blocks - total blocks = "; 5706 $msg .= $#function_blocks + 1; 5707 gp_message ("verbose", $subr_name, $msg); 5708 5709 for my $i (0 .. $#function_blocks) 5710 { 5711 $msg = "process function block " . $i; 5712 gp_message ("debugXL", $subr_name, $msg); 5713 5714 $msg = "function_blocks[" . $i . "] = ". $function_blocks[$i]; 5715 gp_message ("debugXL", $subr_name, $msg); 5716#------------------------------------------------------------------------------ 5717# This split produces an empty first field. This is why we skip this in the 5718# loop below. 5719#------------------------------------------------------------------------------ 5720 my @entries = split ($separator, $function_blocks[$i]); 5721 5722#------------------------------------------------------------------------------ 5723# An example of the content of array @entries: 5724# <empty line> 5725# 6:0x0003ad20 drand48 0.100 0.084 768240570 0 5726# 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0 5727# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 5728#------------------------------------------------------------------------------ 5729 for my $k (1 .. $#entries) 5730 { 5731 my $input_line = $entries[$k]; 5732 5733 $msg = "input_line = entries[" . $k . "] = ". $entries[$k]; 5734 gp_message ("debugXL", $subr_name, $msg); 5735 5736 my ($hex_address_ref, $marker_ref, $reduced_line_ref, 5737 $list_with_metrics_ref) = 5738 split_function_data_line (\$input_line); 5739 5740 $full_hex_address = ${ $hex_address_ref }; 5741 $marker_target_function = ${ $marker_ref }; 5742 $routine = ${ $reduced_line_ref }; 5743 $all_metrics = ${ $list_with_metrics_ref }; 5744 5745 $msg = "RESULT full_hex_address = " . $full_hex_address; 5746 $msg .= " -- metric values = " . $all_metrics; 5747 $msg .= " -- marker = " . $marker_target_function; 5748 $msg .= " -- function name = " . $routine; 5749 gp_message ("debugXL", $subr_name, $msg); 5750 5751 $metrics_length = length ($all_metrics); 5752 $max_metrics_length = max ($max_metrics_length, $metrics_length); 5753 5754 if ($full_hex_address =~ /(\d+):0x(\S+)/) 5755 { 5756 $hex_address = "0x" . $2; 5757 } 5758 push (@marker, $marker_target_function); 5759 5760 push (@address_field, $hex_address); 5761 push (@address_field, $full_hex_address); 5762 $msg = "pushed " . $full_hex_address; 5763 $msg .= " to array address_field"; 5764 gp_message ("debugXL", $subr_name, $msg); 5765 5766 $modified_line = $all_metrics . " " . $routine; 5767 gp_message ("debugXL", $subr_name, "xxxxxxx = $modified_line"); 5768 5769 push (@metric_values, $all_metrics); 5770 $msg = "pushed " . $all_metrics . " to array metric_values"; 5771 gp_message ("debugXL", $subr_name, $msg); 5772 5773 push (@function_names, $routine); 5774 $msg = "pushed " . $routine . " to array function_names"; 5775 gp_message ("debugXL", $subr_name, $msg); 5776 } 5777 5778 $total_header_lines = $#header_lines + 1; 5779 $msg = "total_header_lines = " . $total_header_lines; 5780 gp_message ("debugXL", $subr_name, $msg); 5781 5782 gp_message ("debugXL", $subr_name, "Final output"); 5783 for my $i (keys @header_lines) 5784 { 5785 gp_message ("debugXL", $subr_name, "$header_lines[$i]"); 5786 } 5787 for my $i (0 .. $#function_names) 5788 { 5789 $msg = $metric_values[$i] . " " . $marker[$i]; 5790 $msg .= $function_names[$i] . " (" . $address_field[$i] . ")"; 5791 gp_message ("debugXL", $subr_name, $msg); 5792 } 5793#------------------------------------------------------------------------------ 5794# Check if this function has multiple occurrences. 5795# TBD: Replace by the function call for this. 5796#------------------------------------------------------------------------------ 5797 $msg = "check for multiple occurrences - function_names = "; 5798 $msg .= ($#function_names + 1); 5799 gp_message ("debugXL", $subr_name, $msg); 5800 5801 for my $i (0 .. $#function_names) 5802 { 5803 my $current_address = $address_field[$i]; 5804 my $found_a_match; 5805 my $ref_index; 5806 my $alt_name; 5807 my $addr_offset; 5808 5809 $routine = $function_names[$i]; 5810 $alt_name = $routine; 5811 gp_message ("debugXL", $subr_name, "checking for routine = $routine"); 5812 if (exists ($g_multi_count_function{$routine})) 5813 { 5814#------------------------------------------------------------------------------ 5815# TBD: Scan all of the function_info list. Or beter: add index to 5816# g_multi_count_function. 5817#------------------------------------------------------------------------------ 5818 5819 $found_a_match = $FALSE; 5820 5821 $msg = $routine . ": occurrences = "; 5822 $msg .= $g_function_occurrences{$routine}; 5823 gp_message ("debugXL", $subr_name, $msg); 5824 5825 for my $ref (keys @{ $g_map_function_to_index{$routine} }) 5826 { 5827 $ref_index = $g_map_function_to_index{$routine}[$ref]; 5828 5829 $msg = $routine . ": retrieving duplicate entry at "; 5830 $msg .= "ref_index = " . $ref_index; 5831 gp_message ("debugXL", $subr_name, $msg); 5832 $msg = $routine . ": function_info[" . $ref_index; 5833 $msg .= "]{alt_name} = "; 5834 $msg .= $function_info[$ref_index]{'alt_name'}; 5835 gp_message ("debugXL", $subr_name, $msg); 5836 5837 $addr_offset = $function_info[$ref_index]{"addressobjtext"}; 5838 $msg = $routine . ": addr_offset = " . $addr_offset; 5839 gp_message ("debugXL", $subr_name, $msg); 5840 5841 $addr_offset =~ s/$get_addr_offset_regex//; 5842 $msg = $routine . ": addr_offset = " . $addr_offset; 5843 gp_message ("debugXL", $subr_name, $msg); 5844 5845 if ($addr_offset eq $current_address) 5846 { 5847 $found_a_match = $TRUE; 5848 last; 5849 } 5850 } 5851 $msg = $function_info[$ref_index]{'alt_name'}; 5852 $msg .= " is the actual function for i = " . $i . " "; 5853 $msg .= $found_a_match; 5854 gp_message ("debugXL", $subr_name, $msg); 5855 5856 $alt_name = $function_info[$ref_index]{'alt_name'}; 5857 } 5858 gp_message ("debugXL", $subr_name, "alt_name = $alt_name"); 5859 } 5860 $msg = "completed the check for multiple occurrences"; 5861 gp_message ("debugXL", $subr_name, $msg); 5862 5863#------------------------------------------------------------------------------ 5864# Figure out the column width. Since the columns in the header may include 5865# spaces, we use the first line with metrics for this. 5866#------------------------------------------------------------------------------ 5867 my $top_header = $metric_values[0]; 5868 my $word_index_values_ref = find_words_in_line (\$top_header); 5869 my @word_index_values = @{ $word_index_values_ref }; 5870 5871# $i = 0 0 4 5872# $i = 1 10 14 5873# $i = 2 21 31 5874# $i = 3 35 42 5875 for my $i (keys @word_index_values) 5876 { 5877 $msg = "i = " . $i . " " . $word_index_values[$i][0] . " "; 5878 $msg .= $word_index_values[$i][1]; 5879 gp_message ("debugXL", $subr_name, $msg); 5880 } 5881 5882#------------------------------------------------------------------------------ 5883# Empty the buffers before processing the next block with data. 5884#------------------------------------------------------------------------------ 5885 @function_names = (); 5886 @metric_values = (); 5887 @address_field = (); 5888 @marker = (); 5889 5890 $msg = "erased contents of arrays function_names, metric_values, "; 5891 $msg .= "address_field, and marker"; 5892 gp_message ("debugXL", $subr_name, $msg); 5893 5894 } 5895 5896 push (@html_metric_sort_header, "<i>"); 5897 for my $i (0 .. $#top_level_header) 5898 { 5899 $html_line = $top_level_header[$i] . "<br>"; 5900 push (@html_metric_sort_header, $html_line); 5901 } 5902 push (@html_metric_sort_header, "</i>"); 5903 5904 print CALLER_CALLEE_OUT $html_header; 5905 print CALLER_CALLEE_OUT $html_home; 5906 print CALLER_CALLEE_OUT $html_title_header; 5907 print CALLER_CALLEE_OUT "$_" for @g_html_experiment_stats; 5908## print CALLER_CALLEE_OUT "<br>\n"; 5909## print CALLER_CALLEE_OUT "$_\n" for @html_metric_sort_header; 5910 print CALLER_CALLEE_OUT "<pre>\n"; 5911 print CALLER_CALLEE_OUT "$_\n" for @html_caller_callee; 5912 print CALLER_CALLEE_OUT "</pre>\n"; 5913 5914#------------------------------------------------------------------------------ 5915# Get the acknowledgement, return to main link, and final html statements. 5916#------------------------------------------------------------------------------ 5917 $html_home = ${ generate_home_link ("left") }; 5918 $html_acknowledgement = ${ create_html_credits () }; 5919 $html_end = ${ terminate_html_document () }; 5920 5921 print CALLER_CALLEE_OUT $html_home; 5922 print CALLER_CALLEE_OUT "<br>\n"; 5923 print CALLER_CALLEE_OUT $html_acknowledgement; 5924 print CALLER_CALLEE_OUT $html_end; 5925 5926 close (CALLER_CALLEE_OUT); 5927 5928 $msg = "the caller-callee information has been generated"; 5929 gp_message ("verbose", $subr_name, $msg); 5930 5931 return (0); 5932 5933} #-- End of subroutine generate_caller_callee 5934 5935#------------------------------------------------------------------------------ 5936# Generate the html version of the disassembly file. 5937# 5938# Note to self (TBD) 5939# https://community.intel.com/t5/Intel-oneAPI-AI-Analytics/bd-p/ai-analytics-toolkit 5940#------------------------------------------------------------------------------ 5941sub generate_dis_html 5942{ 5943 my $subr_name = get_my_name (); 5944 5945 my ($target_function_ref, $number_of_metrics_ref, $function_info_ref, 5946 $function_address_and_index_ref, $outputdir_ref, $func_ref, 5947 $source_line_ref, $metric_ref, $addressobj_index_ref) = @_; 5948 5949 my $target_function = ${ $target_function_ref }; 5950 my $number_of_metrics = ${ $number_of_metrics_ref }; 5951 my @function_info = @{ $function_info_ref }; 5952 my %function_address_and_index = %{ $function_address_and_index_ref }; 5953 my $outputdir = ${ $outputdir_ref }; 5954 my $func = ${ $func_ref }; 5955 my @source_line = @{ $source_line_ref }; 5956 my @metric = @{ $metric_ref }; 5957 my %addressobj_index = %{ $addressobj_index_ref }; 5958 5959 my $dec_instruction_start; 5960 my $dec_instruction_end; 5961 my $hex_instruction_start; 5962 my $hex_instruction_end; 5963 5964 my @colour_line = (); 5965 my $hot_line; 5966 my $metric_values; 5967 my $src_line; 5968 my $dec_instr_address; 5969 my $instruction; 5970 my $operands; 5971 5972 my $html_new_line = "<br>"; 5973 my $add_new_line_before; 5974 my $add_new_line_after; 5975 my $address_key; 5976 my $boldface; 5977 my $file; 5978 my $filename = $func; 5979 my $func_name; 5980 my $orig_hex_instr_address; 5981 my $hex_instr_address; 5982 my $index_string; 5983 my $input_metric; 5984 my $linenumber; 5985 my $name; 5986 my $last_address; 5987 my $last_address_in_hex; 5988 5989 my $file_title; 5990 my $html_header; 5991 my $html_home; 5992 my $html_end; 5993 5994 my $branch_regex = $g_arch_specific_settings{"regex"}; 5995 my $convert_to_dot = $g_locale_settings{"convert_to_dot"}; 5996 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 5997 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; 5998 my $linksubexp = $g_arch_specific_settings{"linksubexp"}; 5999 my $subexp = $g_arch_specific_settings{"subexp"}; 6000 6001 my $file_is_empty; 6002 6003 my %branch_target = (); 6004 my %branch_target_no_ref = (); 6005 my @disassembly_file = (); 6006 my %extended_branch_target = (); 6007 my %inverse_branch_target = (); 6008 my @metrics = (); 6009 my @modified_html = (); 6010 6011 my $branch_target_ref; 6012 my $extended_branch_target_ref; 6013 my $branch_target_no_ref_ref; 6014 6015 my $branch_address; 6016 my $dec_branch_address; 6017 my $found_it; 6018 my $found_it_ref; 6019 my $func_name_in_dis_file; 6020 my $hex_branch_target; 6021 my $instruction_address; 6022 my $instruction_offset; 6023 my $link; 6024 my $modified_line; 6025 my $raw_hex_branch_target; 6026 my $src_line_ref; 6027 my $threshold_line; 6028 my $html_dis_out = $func . ".html"; 6029 6030#------------------------------------------------------------------------------ 6031# The regex section. 6032#------------------------------------------------------------------------------ 6033 my $call_regex = '.*([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)'; 6034 my $line_of_interest_regex = '^#*\s+([\d' . $decimal_separator . '\s+]+)\[\s*(\d+|\?)\]'; 6035 my $white_space_regex = '\s+'; 6036 my $first_integer_regex = '^\d+$'; 6037 my $integer_regex = '\d+'; 6038 my $qmark_regex = '\?'; 6039 my $src_regex = '(\s*)(\d+)\.(.*)'; 6040 my $function_regex = '^(\s*)<Function:\s(.*)>'; 6041 my $end_src_header_regex = "(^\\s+)(\\d+)\\.\\s+(.*)"; 6042 my $end_dis_header_regex = "(^\\s+)(<Function: )(.*)>"; 6043 my $control_flow_1_regex = 'j[a-z]+'; 6044 my $control_flow_2_regex = 'call'; 6045 my $control_flow_3_regex = 'ret'; 6046 6047## my $function_call_regex2 = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*'; 6048## my $endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])'; 6049#------------------------------------------------------------------------------ 6050# Dynamic. Computed below. 6051# 6052# TBD: Try to move these up. 6053#------------------------------------------------------------------------------ 6054 my $dis_regex; 6055 my $metric_regex; 6056 6057 gp_message ("debug", $subr_name, "g_branch_regex = $g_branch_regex"); 6058 gp_message ("debug", $subr_name, "call_regex = $call_regex"); 6059 gp_message ("debug", $subr_name, "g_function_call_v2_regex = $g_function_call_v2_regex"); 6060 6061 my $the_title = set_title ($function_info_ref, $func, "disassembly"); 6062 6063 gp_message ("debug", $subr_name, "the_title = $the_title"); 6064 6065 $file_title = $the_title; 6066 $html_header = ${ create_html_header (\$file_title) }; 6067 $html_home = ${ generate_home_link ("right") }; 6068 6069 push (@modified_html, $html_header); 6070 push (@modified_html, $html_home); 6071 push (@modified_html, "<pre>"); 6072 6073#------------------------------------------------------------------------------ 6074# Open the input and output files. 6075#------------------------------------------------------------------------------ 6076 open (INPUT_DISASSEMBLY, "<", $filename) 6077 or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'"); 6078 gp_message ("debug", $subr_name , "opened file $filename for reading"); 6079 6080 open (HTML_OUTPUT, ">", $html_dis_out) 6081 or die ("$subr_name - unable to open file $html_dis_out for writing: '$!'"); 6082 gp_message ("debug", $subr_name , "opened file $html_dis_out for writing"); 6083 6084#------------------------------------------------------------------------------ 6085# Check if the file is empty 6086#------------------------------------------------------------------------------ 6087 $file_is_empty = is_file_empty ($filename); 6088 if ($file_is_empty) 6089 { 6090 6091#------------------------------------------------------------------------------ 6092# The input file is empty. Write a message in the html file and exit. 6093#------------------------------------------------------------------------------ 6094 gp_message ("debug", $subr_name ,"file $filename is empty"); 6095 6096 my $comment = "No disassembly generated by $tool_name - file $filename is empty"; 6097 my $gp_error_file = $outputdir . "gp-listings.err"; 6098 6099 my $html_empty_file_ref = html_text_empty_file (\$comment, \$gp_error_file); 6100 my @html_empty_file = @{ $html_empty_file_ref }; 6101 6102 print HTML_OUTPUT "$_\n" for @html_empty_file; 6103 6104 close (HTML_OUTPUT); 6105 6106 return (\@source_line); 6107 } 6108 else 6109 { 6110 6111#------------------------------------------------------------------------------ 6112# Read the file into memory. 6113#------------------------------------------------------------------------------ 6114 chomp (@disassembly_file = <INPUT_DISASSEMBLY>); 6115 gp_message ("debug", $subr_name ,"read file $filename into memory"); 6116 } 6117 6118 my $max_length_first_metric = 0; 6119 my $src_line_no; 6120 6121#------------------------------------------------------------------------------ 6122# First scan through the assembly listing. 6123#------------------------------------------------------------------------------ 6124 for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++) 6125 { 6126 my $input_line = $disassembly_file[$line_no]; 6127 gp_message ("debugXL", $subr_name, "[line $line_no] $input_line"); 6128 6129 if ($input_line =~ /$line_of_interest_regex/) 6130 { 6131 6132#------------------------------------------------------------------------------ 6133# Found a matching line. Examples are: 6134# 0.370 [37] 4021d1: addsd %xmm0,%xmm1 6135# ## 1.001 [36] 4021d5: add $0x1,%rax 6136#------------------------------------------------------------------------------ 6137 gp_message ("debugXL", $subr_name, "selected line \$1 = $1 \$2 = $2"); 6138 6139 if (defined ($2) and defined($1)) 6140 { 6141 @metrics = split (/$white_space_regex/ ,$1); 6142 $src_line_no = $2; 6143 } 6144 else 6145 { 6146 my $msg = "$input_line has an unexpected format"; 6147 gp_message ("assertion", $subr_name, $msg); 6148 } 6149 6150#------------------------------------------------------------------------------ 6151# Compute the maximum length of the first metric and pad the field from the 6152# left later on. The fractional part is ignored. 6153#------------------------------------------------------------------------------ 6154 my $first_metric = $metrics[0]; 6155 my $new_length; 6156 if ($first_metric =~ /$first_integer_regex/) 6157 { 6158 $new_length = length ($first_metric); 6159 } 6160 else 6161 { 6162 my @fields = split (/$decimal_separator/, $first_metric); 6163 $new_length = length ($fields[0]); 6164 } 6165 $max_length_first_metric = max ($max_length_first_metric, $new_length); 6166 my $msg; 6167 $msg = "first_metric = $first_metric " . 6168 "max_length_first_metric = $max_length_first_metric"; 6169 gp_message ("debugXL", $subr_name, $msg); 6170 6171 if ($src_line_no !~ /$qmark_regex/) 6172#------------------------------------------------------------------------------ 6173# The source code line number is known and is stored. 6174#------------------------------------------------------------------------------ 6175 { 6176 $source_line[$line_no] = $src_line_no; 6177 my $msg; 6178 $msg = "found an instruction with a source line ref:"; 6179 $msg .= " source_line[$line_no] = $source_line[$line_no]"; 6180 gp_message ("debugXL", $subr_name, $msg); 6181 } 6182 6183#------------------------------------------------------------------------------ 6184# Check for function calls. If found, get the address offset from $4 and 6185# compute the target address. 6186#------------------------------------------------------------------------------ 6187 ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) = 6188 check_and_proc_dis_func_call ( 6189 \$input_line, 6190 \$line_no, 6191 \%branch_target, 6192 \%extended_branch_target); 6193 $found_it = ${ $found_it_ref }; 6194 6195 if ($found_it) 6196 { 6197 %branch_target = %{ $branch_target_ref }; 6198 %extended_branch_target = %{ $extended_branch_target_ref }; 6199 } 6200 6201#------------------------------------------------------------------------------ 6202# Look for a branch instruction, or the special endbr32/endbr64 instruction 6203# that is also considered to be a branch target. Note that the latter is x86 6204# specific. 6205#------------------------------------------------------------------------------ 6206 ($found_it_ref, $branch_target_ref, $extended_branch_target_ref, 6207 $branch_target_no_ref_ref) = check_and_proc_dis_branches ( 6208 \$input_line, 6209 \$line_no, 6210 \%branch_target, 6211 \%extended_branch_target, 6212 \%branch_target_no_ref); 6213 $found_it = ${ $found_it_ref }; 6214 6215 if ($found_it) 6216 { 6217 %branch_target = %{ $branch_target_ref }; 6218 %extended_branch_target = %{ $extended_branch_target_ref }; 6219 %branch_target_no_ref = %{ $branch_target_no_ref_ref }; 6220 } 6221 } 6222 } #-- End of loop over line_no 6223 6224 %inverse_branch_target = reverse (%extended_branch_target); 6225 6226 gp_message ("debug", $subr_name, "generated inverse of branch target structure"); 6227 gp_message ("debug", $subr_name, "completed parsing file $filename"); 6228 6229 for my $key (sort keys %branch_target) 6230 { 6231 gp_message ("debug", $subr_name, "branch_target{$key} = $branch_target{$key}"); 6232 } 6233 for my $key (sort keys %extended_branch_target) 6234 { 6235 gp_message ("debug", $subr_name, "extended_branch_target{$key} = $extended_branch_target{$key}"); 6236 } 6237 for my $key (sort keys %inverse_branch_target) 6238 { 6239 gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}"); 6240 } 6241 for my $key (sort keys %branch_target_no_ref) 6242 { 6243 gp_message ("debug", $subr_name, "branch_target_no_ref{$key} = $branch_target_no_ref{$key}"); 6244 $inverse_branch_target{$key} = $key; 6245 } 6246 for my $key (sort keys %inverse_branch_target) 6247 { 6248 gp_message ("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}"); 6249 } 6250 6251#------------------------------------------------------------------------------ 6252# Process the disassembly. 6253#------------------------------------------------------------------------------ 6254 6255#------------------------------------------------------------------------------ 6256# Dynamically generate the regexes. 6257#------------------------------------------------------------------------------ 6258 $metric_regex = ''; 6259 for my $metric_used (1 .. $number_of_metrics) 6260 { 6261 $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+'; 6262 } 6263 6264 $dis_regex = '^(#{2}|\s{2})\s+'; 6265 $dis_regex .= '(.*)'; 6266## $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)\s+(.*)'; 6267 $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)(.*)'; 6268 6269 gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex"); 6270 gp_message ("debugXL", $subr_name, "dis_regex = $dis_regex"); 6271 gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); 6272 gp_message ("debugXL", $subr_name, "contents of lines array"); 6273 6274#------------------------------------------------------------------------------ 6275# Identify the header lines. Make the minimal assumptions. 6276# 6277# In both cases, the first line after the header has whitespace. This is 6278# followed by: 6279# 6280# - A source line file has "<line_no>." 6281# - A dissasembly file has "<Function:" 6282# 6283# These are the characteristics we use below. 6284#------------------------------------------------------------------------------ 6285 for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++) 6286 { 6287 my $input_line = $disassembly_file[$line_no]; 6288 gp_message ("debugXL", $subr_name, "[line $line_no] $input_line"); 6289 6290 if ($input_line =~ /$end_src_header_regex/) 6291 { 6292 gp_message ("debugXL", $subr_name, "header time is over - hit source line\n"); 6293 gp_message ("debugXL", $subr_name, "$1 $2 $3\n"); 6294 last; 6295 } 6296 if ($input_line =~ /$end_dis_header_regex/) 6297 { 6298 gp_message ("debugXL", $subr_name, "header time is over - hit disassembly line\n"); 6299 last; 6300 } 6301 push (@modified_html, "<i>" . $input_line . "</i>"); 6302 } 6303 my $line_index = scalar (@modified_html); 6304 gp_message ("debugXL", $subr_name, "final line_index = $line_index"); 6305 6306 for (my $line_no=0; $line_no <= $line_index-1; $line_no++) 6307 { 6308 my $msg = " modified_html[$line_no] = $modified_html[$line_no]"; 6309 gp_message ("debugXL", $subr_name, $msg); 6310 } 6311 6312#------------------------------------------------------------------------------ 6313# Source line: 6314# 20. for (int64_t r=0; r<repeat_count; r++) { 6315# 6316# Disassembly: 6317# 0.340 [37] 401fec: addsd %xmm0,%xmm1 6318# ## 1.311 [36] 401ff0: addq $1,%rax 6319#------------------------------------------------------------------------------ 6320 6321#------------------------------------------------------------------------------ 6322# Find the hot PCs and store them. 6323#------------------------------------------------------------------------------ 6324 my @hot_program_counters = (); 6325 my @transposed_hot_pc = (); 6326 my @max_metric_values = (); 6327 6328 gp_message ("debug", $subr_name, "determine the maximum metric values"); 6329 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) 6330 { 6331 my $input_line = $disassembly_file[$line_no]; 6332 6333 if ( $input_line =~ /$dis_regex/ ) 6334 { 6335## if ( defined ($1) and defined ($2) and defined ($3) and 6336## defined ($4) and defined ($5) and defined ($6) ) 6337 if ( defined ($1) and defined ($2) and defined ($3) and 6338 defined ($4) and defined ($5) ) 6339 { 6340 $hot_line = $1; 6341 $metric_values = $2; 6342 $src_line = $3; 6343 $dec_instr_address = bigint::hex ($4); 6344 $instruction = $5; 6345 if (defined ($6)) 6346 { 6347 my $white_space_regex = '\s*'; 6348 $operands = $6; 6349 $operands =~ s/$white_space_regex//; 6350 } 6351 6352 if ($hot_line eq "##") 6353 { 6354 my @metrics = split (" ", $metric_values); 6355 push (@hot_program_counters, [@metrics]); 6356 } 6357 } 6358 } 6359 } 6360 for my $row (keys @hot_program_counters) 6361 { 6362 my $msg = "$filename row[" . $row . "] ="; 6363 for my $col (keys @{$hot_program_counters[$row]}) 6364 { 6365 $msg .= " $hot_program_counters[$row][$col]"; 6366 $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col]; 6367 } 6368 gp_message ("debugXL", $subr_name, "hot PC = $msg"); 6369 } 6370 for my $row (keys @transposed_hot_pc) 6371 { 6372 my $msg = "$filename row[" . $row . "] ="; 6373 for my $col (keys @{$transposed_hot_pc[$row]}) 6374 { 6375 $msg .= " $transposed_hot_pc[$row][$col]"; 6376 } 6377 gp_message ("debugXL", $subr_name, "$filename transposed = $msg"); 6378 } 6379#------------------------------------------------------------------------------ 6380# Get the maximum metric values and if integer, convert to floating-point. 6381# Since it is easier, we transpose the array and access it over the columns. 6382#------------------------------------------------------------------------------ 6383 for my $row (0 .. $#transposed_hot_pc) 6384 { 6385 my $max_val = 0; 6386 for my $col (0 .. $#{$transposed_hot_pc[$row]}) 6387 { 6388 $max_val = max ($transposed_hot_pc[$row][$col], $max_val); 6389 } 6390 if ($max_val =~ /$integer_regex/) 6391 { 6392 $max_val = sprintf ("%f", $max_val); 6393 } 6394 gp_message ("debugXL", $subr_name, "$filename row = $row max_val = $max_val"); 6395 push (@max_metric_values, $max_val); 6396 } 6397 6398 for my $metric (0 .. $#max_metric_values) 6399 { 6400 my $msg = "$filename maximum[$metric] = $max_metric_values[$metric]"; 6401 gp_message ("debugM", $subr_name, $msg); 6402 } 6403 6404#------------------------------------------------------------------------------ 6405# TBD - Integrate this better. 6406# 6407# Scan the instructions to find the instruction address range. This is used 6408# to determine if a branch is external to this function. 6409#------------------------------------------------------------------------------ 6410 $dec_instruction_start = undef; 6411 $dec_instruction_end = undef; 6412 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) 6413 { 6414 my $input_line = $disassembly_file[$line_no]; 6415 if ( $input_line =~ /$dis_regex/ ) 6416 { 6417# if ( defined ($1) and defined ($2) and defined ($3) and 6418## defined ($4) and defined ($5) and defined ($6) ) 6419 if ( defined ($1) and defined ($2) and defined ($3) and 6420 defined ($4) and defined ($5) ) 6421 { 6422 $hot_line = $1; 6423 $metric_values = $2; 6424 $src_line = $3; 6425 $dec_instr_address = bigint::hex ($4); 6426 $instruction = $5; 6427## $operands = $6; 6428 if (defined ($6)) 6429 { 6430 my $white_space_regex = '\s*'; 6431 $operands = $6; 6432 $operands =~ s/$white_space_regex//; 6433 } 6434 6435 if (defined ($dec_instruction_start)) 6436 { 6437 if ($dec_instr_address < $dec_instruction_start) 6438 { 6439 $dec_instruction_start = $dec_instr_address; 6440 } 6441 } 6442 else 6443 { 6444 $dec_instruction_start = $dec_instr_address; 6445 } 6446 if (defined ($dec_instruction_end)) 6447 { 6448 if ($dec_instr_address > $dec_instruction_end) 6449 { 6450 $dec_instruction_end = $dec_instr_address; 6451 } 6452 } 6453 else 6454 { 6455 $dec_instruction_end = $dec_instr_address; 6456 } 6457 } 6458 } 6459 } 6460 6461 if (defined ($dec_instruction_start) and defined ($dec_instruction_end)) 6462 { 6463 $hex_instruction_start = sprintf ("%x", $dec_instruction_start); 6464 $hex_instruction_end = sprintf ("%x", $dec_instruction_end); 6465 6466 my $msg; 6467 $msg = "$filename $func dec_instruction_start = " . 6468 "$dec_instruction_start (0x$hex_instruction_start)"; 6469 gp_message ("debugXL", $subr_name, $msg); 6470 $msg = "$filename $func dec_instruction_end = " . 6471 "$dec_instruction_end (0x$hex_instruction_end)"; 6472 gp_message ("debugXL", $subr_name, $msg); 6473 } 6474 6475#------------------------------------------------------------------------------ 6476# This is where all the results from above come together. 6477#------------------------------------------------------------------------------ 6478 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++) 6479 { 6480 my $input_line = $disassembly_file[$line_no]; 6481 gp_message ("debugXL", $subr_name, "input_line[$line_no] = $input_line"); 6482 if ( $input_line =~ /$dis_regex/ ) 6483 { 6484 gp_message ("debugXL", $subr_name, "found a disassembly line: $input_line"); 6485 6486 if ( defined ($1) and defined ($2) and defined ($3) and 6487 defined ($4) and defined ($5) ) 6488 { 6489# $branch_target{$hex_branch_target} = 1; 6490# $extended_branch_target{$instruction_address} = $raw_hex_branch_target; 6491 $hot_line = $1; 6492 $metric_values = $2; 6493 $src_line = $3; 6494 $orig_hex_instr_address = $4; 6495 $instruction = $5; 6496## $operands = $6; 6497 6498 my $msg = "disassembly line: $1 $2 $3 $4 $5"; 6499 if (defined ($6)) 6500 { 6501 $msg .= " \$6 = $6"; 6502 my $white_space_regex = '\s*'; 6503 $operands = $6; 6504 $operands =~ s/$white_space_regex//; 6505 } 6506 gp_message ("debugXL", $subr_name, $msg); 6507 6508#------------------------------------------------------------------------------ 6509# Pad the line with the metrics to ensure correct alignment. 6510#------------------------------------------------------------------------------ 6511 my $the_length; 6512 my @split_metrics = split (" ", $metric_values); 6513 my $first_metric = $split_metrics[0]; 6514## if ($first_metric =~ /^\d+$/) 6515 if ($first_metric =~ /$first_integer_regex/) 6516 { 6517 $the_length = length ($first_metric); 6518 } 6519 else 6520 { 6521 my @fields = split (/$decimal_separator/, $first_metric); 6522 $the_length = length ($fields[0]); 6523 } 6524 my $spaces = $max_length_first_metric - $the_length; 6525 my $pad = ""; 6526 for my $p (1 .. $spaces) 6527 { 6528 $pad .= " "; 6529 } 6530 $metric_values = $pad . $metric_values; 6531 gp_message ("debugXL", $subr_name, "pad = $pad"); 6532 gp_message ("debugXL", $subr_name, "metric_values = $metric_values"); 6533 6534#------------------------------------------------------------------------------ 6535# Since the instruction address variable may change and because we need the 6536# original address without html controls, we use a new variable for the 6537# (potentially) modified address. 6538#------------------------------------------------------------------------------ 6539 $hex_instr_address = $orig_hex_instr_address; 6540 $add_new_line_before = $FALSE; 6541 $add_new_line_after = $FALSE; 6542 6543 if ($src_line eq "?") 6544 6545#------------------------------------------------------------------------------ 6546# There is no source line number. Do not add a link. 6547#------------------------------------------------------------------------------ 6548 { 6549 $modified_line = $hot_line . ' ' . $metric_values . ' [' . $src_line . '] '; 6550 gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line"); 6551 } 6552 else 6553 { 6554#------------------------------------------------------------------------------ 6555# There is a source line number. Mark it as link. 6556#------------------------------------------------------------------------------ 6557 $src_line_ref = "[<a href='#line_".$src_line."'>".$src_line."</a>]"; 6558 gp_message ("debugXL", $subr_name, "src_line_ref = $src_line_ref"); 6559 gp_message ("debugXL", $subr_name, "hex_instr_address = $hex_instr_address"); 6560 6561 $modified_line = $hot_line . ' ' . $metric_values . ' ' . $src_line_ref . ' '; 6562 gp_message ("debugXL", $subr_name, "initialized modified_line = $modified_line"); 6563 } 6564 6565#------------------------------------------------------------------------------ 6566# Mark control flow instructions. Several cases need to be distinguished. 6567# 6568# In all cases we give the instruction a specific color, mark it boldface 6569# and add a new-line after the instruction 6570#------------------------------------------------------------------------------ 6571 if ( ($instruction =~ /$control_flow_1_regex/) or 6572 ($instruction =~ /$control_flow_2_regex/) or 6573 ($instruction =~ /$control_flow_3_regex/) ) 6574 { 6575 gp_message ("debugXL", $subr_name, "instruction = $instruction is a control flow instruction"); 6576 6577 $add_new_line_after = $TRUE; 6578 6579 $boldface = $TRUE; 6580 $instruction = color_string ($instruction, $boldface, $g_html_color_scheme{"control_flow"}); 6581 } 6582 6583 if (exists ($extended_branch_target{$hex_instr_address})) 6584#------------------------------------------------------------------------------ 6585# This is a branch instruction and we need to add the target address. 6586# 6587# In case the target address is outside of this load object, the link is 6588# colored differently. 6589# 6590# TBD: Add the name and if possible, a working link to this code. 6591#------------------------------------------------------------------------------ 6592 { 6593 $branch_address = $extended_branch_target{$hex_instr_address}; 6594 6595 $dec_branch_address = bigint::hex ($branch_address); 6596 6597 if ( ($dec_branch_address >= $dec_instruction_start) and 6598 ($dec_branch_address <= $dec_instruction_end) ) 6599#------------------------------------------------------------------------------ 6600# The instruction is within the range. 6601#------------------------------------------------------------------------------ 6602 { 6603 $link = "[ <a href='#".$branch_address."'>".$branch_address."</a> ]"; 6604 } 6605 else 6606 { 6607#------------------------------------------------------------------------------ 6608# The instruction is outside of the range. Change the color of the link. 6609#------------------------------------------------------------------------------ 6610 gp_message ("debugXL", $subr_name, "address is outside of range"); 6611 6612 $link = "[ <a href='#".$branch_address; 6613 $link .= "' style='color:$g_html_color_scheme{'link_outside_range'}'>"; 6614 $link .= $branch_address."</a> ]"; 6615 } 6616 gp_message ("debugXL", $subr_name, "address exists new link = $link"); 6617 6618 $operands .= ' ' . $link; 6619 gp_message ("debugXL", $subr_name, "update #1 modified_line = $modified_line"); 6620 } 6621 if (exists ($branch_target_no_ref{$hex_instr_address})) 6622 { 6623 gp_message ("debugXL", $subr_name, "NEWBR branch_target_no_ref{$hex_instr_address} = $branch_target_no_ref{$hex_instr_address}"); 6624 } 6625## if (exists ($inverse_branch_target{$hex_instr_address}) or 6626## exists ($branch_target_no_ref{$hex_instr_address})) 6627 if (exists ($inverse_branch_target{$hex_instr_address})) 6628#------------------------------------------------------------------------------ 6629# This is a target address and we need to define the instruction address to be 6630# a label. 6631#------------------------------------------------------------------------------ 6632 { 6633 $add_new_line_before = $TRUE; 6634 6635 my $branch_target = $inverse_branch_target{$hex_instr_address}; 6636 my $target = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>:"; 6637 gp_message ("debugXL", $subr_name, "inverse exists - hex_instr_address = $hex_instr_address"); 6638 gp_message ("debugXL", $subr_name, "inverse exists - add a target target = $target"); 6639 6640 $hex_instr_address = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>"; 6641 gp_message ("debugXL", $subr_name, "update #2 hex_instr_address = $hex_instr_address"); 6642 gp_message ("debugXL", $subr_name, "update #2 modified_line = $modified_line"); 6643 } 6644 6645 $modified_line .= $hex_instr_address . ': ' . $instruction . ' ' . $operands; 6646 6647 gp_message ("debugXL", $subr_name, "final modified_line = $modified_line"); 6648 6649#------------------------------------------------------------------------------ 6650# This is a control flow instruction, but it is the last one and we do not 6651# want to add a newline. 6652#------------------------------------------------------------------------------ 6653 gp_message ("debugXL", $subr_name, "decide where the <br> should go in the html"); 6654 gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after"); 6655 gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before"); 6656 6657 if ( $add_new_line_after and ($orig_hex_instr_address eq $hex_instruction_end) ) 6658 { 6659 $add_new_line_after = $FALSE; 6660 gp_message ("debugXL", $subr_name, "$instruction is the last instruction - do not add a newline"); 6661 } 6662 6663 if ($add_new_line_before) 6664 { 6665 6666#------------------------------------------------------------------------------ 6667# Get the previous line, if any, so that we can check what it is. 6668#------------------------------------------------------------------------------ 6669 my $prev_line = pop (@modified_html); 6670 if ( defined ($prev_line) ) 6671 { 6672 gp_message ("debugXL", $subr_name, "prev_line = $prev_line"); 6673 6674#------------------------------------------------------------------------------ 6675# Restore the previously popped line. 6676#------------------------------------------------------------------------------ 6677 push (@modified_html, $prev_line); 6678 if ($prev_line ne $html_new_line) 6679 { 6680 gp_message ("debugXL", $subr_name, "add_new_line_before = $add_new_line_before pushed $html_new_line"); 6681#------------------------------------------------------------------------------ 6682# There is no new-line yet, so add it. 6683#------------------------------------------------------------------------------ 6684 push (@modified_html, $html_new_line); 6685 } 6686 else 6687 { 6688#------------------------------------------------------------------------------ 6689# It was a new-line, so do nothing and continue. 6690#------------------------------------------------------------------------------ 6691 gp_message ("debugXL", $subr_name, "need to restore $html_new_line"); 6692 } 6693 } 6694 } 6695#------------------------------------------------------------------------------ 6696# Add the newly created line. 6697#------------------------------------------------------------------------------ 6698 6699 if ($hot_line eq "##") 6700#------------------------------------------------------------------------------ 6701# Highlight the most expensive line. 6702#------------------------------------------------------------------------------ 6703 { 6704 $modified_line = set_background_color_string ( 6705 $modified_line, 6706 $g_html_color_scheme{"background_color_hot"}); 6707 } 6708#------------------------------------------------------------------------------ 6709# Sub-highlight the lines close enough to the hot line. 6710#------------------------------------------------------------------------------ 6711 else 6712 { 6713 my @current_metrics = split (" ", $metric_values); 6714 for my $metric (0 .. $#current_metrics) 6715 { 6716 my $current_value; 6717 my $max_value; 6718 $current_value = $current_metrics[$metric]; 6719#------------------------------------------------------------------------------ 6720# As part of the padding process, non-breaking spaces may have been inserted 6721# in an earlier phase. Temporarily remove these to make sure that the maximum 6722# metric values can be computed. 6723#------------------------------------------------------------------------------ 6724 $current_value =~ s/ //g; 6725 if (exists ($max_metric_values[$metric])) 6726 { 6727 $max_value = $max_metric_values[$metric]; 6728 gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); 6729 if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) ) 6730 { 6731# TBD: abs needed? 6732 gp_message ("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value"); 6733 my $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value ); 6734 gp_message ("debugXL", $subr_name, "relative_distance = $relative_distance"); 6735 if (($hp_value > 0) and ($relative_distance >= $hp_value/100.0)) 6736 { 6737 gp_message ("debugXL", $subr_name, "metric $metric is within the relative_distance"); 6738 gp_message ("debugXL", $subr_name, "change bg modified_line = $modified_line"); 6739 $modified_line = set_background_color_string ( 6740 $modified_line, 6741 $g_html_color_scheme{"background_color_lukewarm"}); 6742 last; 6743 } 6744 } 6745 } 6746 } 6747 } 6748 6749## my @max_metric_values = (); 6750 push (@modified_html, $modified_line); 6751 if ($add_new_line_after) 6752 { 6753 gp_message ("debugXL", $subr_name, "add_new_line_after = $add_new_line_after pushed $html_new_line"); 6754 push (@modified_html, $html_new_line); 6755 } 6756 6757 } 6758 else 6759 { 6760 my $msg = "parsing line $input_line"; 6761 gp_message ("assertion", $subr_name, $msg); 6762 } 6763 } 6764 elsif ( $input_line =~ /$src_regex/ ) 6765 { 6766 if ( defined ($1) and defined ($2) ) 6767 { 6768####### BUG? 6769 gp_message ("debugXL", $subr_name, "found a source code line: $input_line"); 6770 gp_message ("debugXL", $subr_name, "\$1 = $1"); 6771 gp_message ("debugXL", $subr_name, "\$2 = $2"); 6772 gp_message ("debugXL", $subr_name, "\$3 = $3"); 6773 my $blanks = $1; 6774 my $src_line = $2; 6775 my $src_code = $3; 6776 6777#------------------------------------------------------------------------------ 6778# We need to replace the "<" symbol in the code by "<". 6779#------------------------------------------------------------------------------ 6780 $src_code =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 6781 6782 my $target = "<a name='line_".$src_line."'>".$src_line.".</a>"; 6783 gp_message ("debugXL", $subr_name, "src target = $target $src_code"); 6784 6785 my $modified_line = $blanks . $target . $src_code; 6786 gp_message ("debugXL", $subr_name, "modified_line = $modified_line"); 6787 push (@modified_html, $modified_line); 6788 } 6789 else 6790 { 6791 my $msg = "parsing line $input_line"; 6792 gp_message ("assertion", $subr_name, $msg); 6793 } 6794 } 6795 elsif ( $input_line =~ /$function_regex/ ) 6796 { 6797 my $html_name; 6798 if (defined ($1) and defined ($2)) 6799 { 6800 $func_name_in_dis_file = $2; 6801 my $spaces = $1; 6802 my $boldface = $TRUE; 6803 gp_message ("debugXL", $subr_name, "function_name = $2"); 6804 my $function_line = "<Function: " . $func_name_in_dis_file . ">"; 6805 6806##### HACK 6807 6808 if ($func_name_in_dis_file eq $target_function) 6809 { 6810 my $color_function_name = color_string ( 6811 $function_line, 6812 $boldface, 6813 $g_html_color_scheme{"target_function_name"}); 6814 my $label = "<a id=\"" . $g_function_tag_id{$target_function} . "\"></a>"; 6815 $html_name = $label . $spaces . "<i>" . $color_function_name . "</i>"; 6816 } 6817 else 6818 { 6819 my $color_function_name = color_string ( 6820 $function_line, 6821 $boldface, 6822 $g_html_color_scheme{"non_target_function_name"}); 6823 $html_name = "<i>" . $spaces . $color_function_name . "</i>"; 6824 } 6825 push (@modified_html, $html_name); 6826 } 6827 else 6828 { 6829 my $msg = "parsing line $input_line"; 6830 gp_message ("assertion", $subr_name, $msg); 6831 } 6832 } 6833 } 6834 6835#------------------------------------------------------------------------------ 6836# Add an extra line with diagnostics. 6837# 6838# TBD: The same is done in process_source but should be done only once. 6839#------------------------------------------------------------------------------ 6840 if ($hp_value > 0) 6841 { 6842 my $rounded_percentage = sprintf ("%.1f", $hp_value); 6843 $threshold_line = "<i>The setting for the highlight percentage"; 6844 $threshold_line .= " (--highlight-percentage) option:"; 6845 $threshold_line .= " " . $rounded_percentage . " (%)</i>"; 6846 } 6847 else 6848 { 6849 $threshold_line = "<i>The highlight percentage feature has not been"; 6850 $threshold_line .= " enabled</i>"; 6851 } 6852 6853 $html_home = ${ generate_home_link ("left") }; 6854 $html_end = ${ terminate_html_document () }; 6855 6856 push (@modified_html, "</pre>"); 6857 push (@modified_html, $html_new_line); 6858 push (@modified_html, $threshold_line); 6859 push (@modified_html, $html_home); 6860 push (@modified_html, $html_new_line); 6861 push (@modified_html, $g_html_credits_line); 6862 push (@modified_html, $html_end); 6863 6864 for my $i (0 .. $#modified_html) 6865 { 6866 gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]"); 6867 } 6868 6869 for my $i (0 .. $#modified_html) 6870 { 6871 print HTML_OUTPUT "$modified_html[$i]" . "\n"; 6872 } 6873 6874 close (HTML_OUTPUT); 6875 close (INPUT_DISASSEMBLY); 6876 6877 gp_message ("debug", $subr_name, "output is in file $html_dis_out"); 6878 gp_message ("debug", $subr_name ,"completed processing disassembly"); 6879 6880 undef %branch_target; 6881 undef %extended_branch_target; 6882 undef %inverse_branch_target; 6883 6884 return (\@source_line, \@metric); 6885 6886} #-- End of subroutine generate_dis_html 6887 6888#------------------------------------------------------------------------------ 6889# Generate all the function level information. 6890#------------------------------------------------------------------------------ 6891sub generate_function_level_info 6892{ 6893 my $subr_name = get_my_name (); 6894 6895 my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string, 6896 $sort_fields_ref) = @_; 6897 6898 my @exp_dir_list = @{ $exp_dir_list_ref }; 6899 my @sort_fields = @{ $sort_fields_ref }; 6900 6901 my $expr_name; 6902 my $first_metric; 6903 my $gp_display_text_cmd; 6904 my $gp_functions_cmd; 6905 my $ignore_value; 6906 my $msg; 6907 my $script_pc_metrics; 6908 6909 my $outputdir = append_forward_slash ($input_string); 6910 6911 my $script_file_PC = $outputdir."gp-script-PC"; 6912 my $result_file = $outputdir."gp-out-PC.err"; 6913 my $gp_error_file = $outputdir."gp-out-PC.err"; 6914 my $func_limit = $g_user_settings{func_limit}{current_value}; 6915 6916#------------------------------------------------------------------------------ 6917# The number of entries in the Function Overview includes <Total>, but that is 6918# not a concern to the user and we add "1" to compensate for this. 6919#------------------------------------------------------------------------------ 6920 $func_limit += 1; 6921 6922 gp_message ("debug", $subr_name, "increased the local value for func_limit = $func_limit"); 6923 6924 $expr_name = join (" ", @exp_dir_list); 6925 6926 gp_message ("debug", $subr_name, "expr_name = $expr_name"); 6927 6928 for my $i (0 .. $#sort_fields) 6929 { 6930 gp_message ("debug", $subr_name, "sort_fields[$i] = $sort_fields[$i]"); 6931 } 6932 6933# Ruud $count = 0; 6934 6935 gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files"); 6936 6937 open (SCRIPT_PC, ">", $script_file_PC) 6938 or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'"); 6939 gp_message ("debug", $subr_name, "opened file $script_file_PC for writing"); 6940 6941#------------------------------------------------------------------------------ 6942# Get the list of functions. 6943#------------------------------------------------------------------------------ 6944 6945#------------------------------------------------------------------------------ 6946# Get the first metric. 6947#------------------------------------------------------------------------------ 6948 $summary_metrics =~ /^([^:]+)/; 6949 $first_metric = $1; 6950 $g_first_metric = $1; 6951 $script_pc_metrics = "address:$summary_metrics"; 6952 6953 gp_message ("debugXL", $subr_name, "$func_limit"); 6954 gp_message ("debugXL", $subr_name, "$summary_metrics"); 6955 gp_message ("debugXL", $subr_name, "$first_metric"); 6956 gp_message ("debugXL", $subr_name, "$script_pc_metrics"); 6957 6958# Temporarily disabled print SCRIPT_PC "# limit $func_limit\n"; 6959# Temporarily disabled print SCRIPT_PC "limit $func_limit\n"; 6960 print SCRIPT_PC "# thread_select all\n"; 6961 print SCRIPT_PC "thread_select all\n"; 6962 6963#------------------------------------------------------------------------------ 6964# Empty header. 6965# TBD: Is still needed? Also, add the header command. 6966#------------------------------------------------------------------------------ 6967 print SCRIPT_PC "# outfile $outputdir"."header\n"; 6968 print SCRIPT_PC "outfile $outputdir"."header\n"; 6969 6970#------------------------------------------------------------------------------ 6971# Else the output from the next line goes to last sort.func 6972#------------------------------------------------------------------------------ 6973 print SCRIPT_PC "# outfile $outputdir"."gp-metrics-functions-PC\n"; 6974 print SCRIPT_PC "outfile $outputdir"."gp-metrics-functions-PC\n"; 6975 print SCRIPT_PC "# metrics $script_pc_metrics\n"; 6976 print SCRIPT_PC "metrics $script_pc_metrics\n"; 6977#------------------------------------------------------------------------------ 6978# Not really sorted 6979#------------------------------------------------------------------------------ 6980 print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC\n"; 6981 print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC\n"; 6982 print SCRIPT_PC "# functions\n"; 6983 print SCRIPT_PC "functions\n"; 6984 6985 print SCRIPT_PC "# outfile $outputdir"."functions.sort.func-PC2\n"; 6986 print SCRIPT_PC "outfile $outputdir"."functions.sort.func-PC2\n"; 6987 print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; 6988 print SCRIPT_PC "metrics address:name:$summary_metrics\n"; 6989 print SCRIPT_PC "# sort $first_metric\n"; 6990 print SCRIPT_PC "sort $first_metric\n"; 6991 print SCRIPT_PC "# functions\n"; 6992 print SCRIPT_PC "functions\n"; 6993#------------------------------------------------------------------------------ 6994# Go through all the possible metrics and sort by each of them. 6995#------------------------------------------------------------------------------ 6996 for my $field (@sort_fields) 6997 { 6998 gp_message ("debug", $subr_name, "sort_fields field = $field"); 6999#------------------------------------------------------------------------------ 7000# Else the output from the next line goes to last sort.func 7001#------------------------------------------------------------------------------ 7002 print SCRIPT_PC "# outfile $outputdir"."gp-metrics-".$field."-PC\n"; 7003 print SCRIPT_PC "outfile $outputdir"."gp-metrics-".$field."-PC\n"; 7004 print SCRIPT_PC "# metrics $script_pc_metrics\n"; 7005 print SCRIPT_PC "metrics $script_pc_metrics\n"; 7006 print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC\n"; 7007 print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC\n"; 7008 print SCRIPT_PC "# sort $field\n"; 7009 print SCRIPT_PC "sort $field\n"; 7010 print SCRIPT_PC "# functions\n"; 7011 print SCRIPT_PC "functions\n"; 7012 7013 print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; 7014 print SCRIPT_PC "metrics address:name:$summary_metrics\n"; 7015 print SCRIPT_PC "# outfile $outputdir".$field.".sort.func-PC2\n"; 7016 print SCRIPT_PC "outfile $outputdir".$field.".sort.func-PC2\n"; 7017 print SCRIPT_PC "# sort $field\n"; 7018 print SCRIPT_PC "sort $field\n"; 7019 print SCRIPT_PC "# functions\n"; 7020 print SCRIPT_PC "functions\n"; 7021 } 7022 7023#------------------------------------------------------------------------------ 7024# Get caller-callee list 7025#------------------------------------------------------------------------------ 7026 print SCRIPT_PC "# outfile " . $outputdir."caller-callee-PC2\n"; 7027 print SCRIPT_PC "outfile " . $outputdir."caller-callee-PC2\n"; 7028 print SCRIPT_PC "# metrics address:name:$summary_metrics\n"; 7029 print SCRIPT_PC "metrics address:name:$summary_metrics\n"; 7030 print SCRIPT_PC "# callers-callees\n"; 7031 print SCRIPT_PC "callers-callees\n"; 7032#------------------------------------------------------------------------------ 7033# Else the output from the next line goes to last sort.func 7034#------------------------------------------------------------------------------ 7035 print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calls-PC\n"; 7036 print SCRIPT_PC "outfile $outputdir"."gp-metrics-calls-PC\n"; 7037 $script_pc_metrics = "address:$call_metrics"; 7038 print SCRIPT_PC "# metrics $script_pc_metrics\n"; 7039 print SCRIPT_PC "metrics $script_pc_metrics\n"; 7040 7041#------------------------------------------------------------------------------ 7042# Not really sorted 7043#------------------------------------------------------------------------------ 7044 print SCRIPT_PC "# outfile $outputdir"."calls.sort.func-PC\n"; 7045 print SCRIPT_PC "outfile $outputdir"."calls.sort.func-PC\n"; 7046 7047#------------------------------------------------------------------------------ 7048# Get caller-callee list 7049#------------------------------------------------------------------------------ 7050 print SCRIPT_PC "# callers-callees\n"; 7051 print SCRIPT_PC "callers-callees\n"; 7052 7053#------------------------------------------------------------------------------ 7054# Else the output from the next line goes to last sort.func 7055#------------------------------------------------------------------------------ 7056 print SCRIPT_PC "# outfile $outputdir"."gp-metrics-calltree-PC\n"; 7057 print SCRIPT_PC "outfile $outputdir"."gp-metrics-calltree-PC\n"; 7058 print SCRIPT_PC "# metrics $script_pc_metrics\n"; 7059 print SCRIPT_PC "metrics $script_pc_metrics\n"; 7060 7061 if ($g_user_settings{"calltree"}{"current_value"} eq "on") 7062 { 7063 gp_message ("verbose", $subr_name, "Generate the file with the calltree information"); 7064#------------------------------------------------------------------------------ 7065# Get calltree list 7066#------------------------------------------------------------------------------ 7067 print SCRIPT_PC "# outfile $outputdir"."calltree.sort.func-PC\n"; 7068 print SCRIPT_PC "outfile $outputdir"."calltree.sort.func-PC\n"; 7069 print SCRIPT_PC "# calltree\n"; 7070 print SCRIPT_PC "calltree\n"; 7071 } 7072 7073#------------------------------------------------------------------------------ 7074# Get the default set of metrics 7075#------------------------------------------------------------------------------ 7076 my $full_metrics_ref; 7077 my $all_metrics; 7078 my $full_function_view = $outputdir . "functions.full"; 7079 7080 $full_metrics_ref = get_all_the_metrics (\$expr_name, \$outputdir); 7081 7082 $all_metrics = "address:name:"; 7083 $all_metrics .= ${$full_metrics_ref}; 7084 gp_message ("debug", $subr_name, "all_metrics = $all_metrics"); 7085#------------------------------------------------------------------------------ 7086# Get the name, address, and full overview of all metrics for all functions 7087#------------------------------------------------------------------------------ 7088 print SCRIPT_PC "# limit 0\n"; 7089 print SCRIPT_PC "limit 0\n"; 7090 print SCRIPT_PC "# metrics $all_metrics\n"; 7091 print SCRIPT_PC "metrics $all_metrics\n"; 7092 print SCRIPT_PC "# thread_select all\n"; 7093 print SCRIPT_PC "thread_select all\n"; 7094 print SCRIPT_PC "# sort default\n"; 7095 print SCRIPT_PC "sort default\n"; 7096 print SCRIPT_PC "# outfile $full_function_view\n"; 7097 print SCRIPT_PC "outfile $full_function_view\n"; 7098 print SCRIPT_PC "# functions\n"; 7099 print SCRIPT_PC "functions\n"; 7100 7101 close (SCRIPT_PC); 7102 7103 $result_file = $outputdir."gp-out-PC.err"; 7104 $gp_error_file = $outputdir.$g_gp_error_logfile; 7105 7106 $gp_functions_cmd = "$GP_DISPLAY_TEXT -limit $func_limit "; 7107 $gp_functions_cmd .= "-viewmode machine -compare off "; 7108 $gp_functions_cmd .= "-script $script_file_PC $expr_name"; 7109 7110 gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function level information"); 7111 7112 $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file"; 7113 7114 gp_message ("debugXL", $subr_name,"cmd = $gp_display_text_cmd"); 7115 7116 my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 7117 7118 if ($error_code != 0) 7119 { 7120 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 7121 $error_code, 7122 $gp_error_file); 7123 gp_message ("abort", $subr_name, "execution terminated"); 7124 } 7125 7126#------------------------------------------------------------------------------ 7127# Parse the full function view and store the data. 7128#------------------------------------------------------------------------------ 7129 my @input_data = (); 7130 my $empty_line_regex = '^\s*$'; 7131 7132## my $full_function_view = $outputdir . "functions.full"; 7133 7134 open (ALL_FUNC_DATA, "<", $full_function_view) 7135 or die ("$subr_name - unable to open output file $full_function_view for reading '$!'"); 7136 gp_message ("debug", $subr_name, "opened file $full_function_view for reading"); 7137 7138 chomp (@input_data = <ALL_FUNC_DATA>); 7139 7140 my $start_scanning = $FALSE; 7141 for (my $line = 0; $line <= $#input_data; $line++) 7142 { 7143 my $input_line = $input_data[$line]; 7144 7145 $input_line =~ s/ -- no functions found//; 7146 $input_data[$line] =~ s/ -- no functions found//; 7147 7148 $msg = "line = " . $line . " input_line = " . $input_line; 7149 gp_message ("debugXL", $subr_name, $msg); 7150 7151# if ($input_line =~ /^<Total>\s+.*/) 7152 if ($input_line =~ /\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)/) 7153 { 7154 $start_scanning = $TRUE; 7155 } 7156 elsif ($input_line =~ /$empty_line_regex/) 7157 { 7158 $start_scanning = $FALSE; 7159 } 7160 7161 if ($start_scanning) 7162 { 7163 gp_message ("debugXL", $subr_name, "$line: $input_data[$line]"); 7164 7165 push (@g_full_function_view_table, $input_data[$line]); 7166 7167 my $hex_address; 7168 my $full_hex_address = $1; 7169 my $routine = $2; 7170 my $all_metrics = $3; 7171 if ($full_hex_address =~ /(\d+):0x(\S+)/) 7172 { 7173 $hex_address = "0x" . $2; 7174 } 7175 $g_function_view_all{$routine}{"hex_address"} = $hex_address; 7176 $g_function_view_all{$routine}{"all_metrics"} = $all_metrics; 7177 } 7178 } 7179 7180 for my $i (keys %g_function_view_all) 7181 { 7182 gp_message ("debugXL", $subr_name, "key = $i $g_function_view_all{$i}{'hex_address'} $g_function_view_all{$i}{'all_metrics'}"); 7183 } 7184 7185 for my $i (keys @g_full_function_view_table) 7186 { 7187 gp_message ("debugXL", $subr_name, "g_full_function_view_table[$i] = $i $g_full_function_view_table[$i]"); 7188 } 7189 7190 return ($script_pc_metrics); 7191 7192} #-- End of subroutine generate_function_level_info 7193 7194#------------------------------------------------------------------------------ 7195# Generate all the files needed for the function view. 7196#------------------------------------------------------------------------------ 7197sub generate_function_view 7198{ 7199 my $subr_name = get_my_name (); 7200 7201 my ($directory_name_ref, $summary_metrics_ref, $number_of_metrics_ref, 7202 $function_info_ref, $function_view_structure_ref, $function_address_info_ref, 7203 $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref) = @_; 7204 7205 my $directory_name = ${ $directory_name_ref }; 7206 my @function_info = @{ $function_info_ref }; 7207 my %function_view_structure = %{ $function_view_structure_ref }; 7208 my $summary_metrics = ${ $summary_metrics_ref }; 7209 my $number_of_metrics = ${ $number_of_metrics_ref }; 7210 my %function_address_info = %{ $function_address_info_ref }; 7211 my @sort_fields = @{ $sort_fields_ref }; 7212 my @exp_dir_list = @{ $exp_dir_list_ref }; 7213 my %addressobjtextm = %{ $addressobjtextm_ref }; 7214 7215 my @abs_path_exp_dirs = (); 7216 my @experiment_directories; 7217 7218 my $target_function; 7219 my $html_line; 7220 my $ftag; 7221 my $routine_length; 7222 my %html_source_functions = (); 7223 7224 my $href_link; 7225 my $infile; 7226 my $input_experiments; 7227 my $keep_value; 7228 my $loadobj; 7229 my $address_field; 7230 my $address_offset; 7231 my $msg; 7232 my $exe; 7233 my $extra_field; 7234 my $new_target_function; 7235 my $file_title; 7236 my $html_output_file; 7237 my $html_function_view; 7238 my $overview_file; 7239 my $exp_name; 7240 my $exp_type; 7241 my $html_header; 7242 my $routine; 7243 my $length_header; 7244 my $length_metrics; 7245 my $full_index_line; 7246 my $acknowledgement; 7247 my @full_function_view_line = (); 7248 my $spaces; 7249 my $size_text; 7250 my $position_text; 7251 my $html_first_metric_file; 7252 my $html_new_line = "<br>"; 7253 my $html_acknowledgement; 7254 my $html_end; 7255 my $html_home; 7256 my $page_title; 7257 my $html_title_header; 7258 7259 my $outputdir = append_forward_slash ($directory_name); 7260 my $LANG = $g_locale_settings{"LANG"}; 7261 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 7262 7263 $input_experiments = join (", ", @exp_dir_list); 7264 7265 for my $i (0 .. $#exp_dir_list) 7266 { 7267 my $dir = get_basename ($exp_dir_list[$i]); 7268 push @abs_path_exp_dirs, $dir; 7269 } 7270 $input_experiments = join (", ", @abs_path_exp_dirs); 7271 7272 gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); 7273 7274#------------------------------------------------------------------------------ 7275# TBD: This should be done only once and much earlier. 7276#------------------------------------------------------------------------------ 7277 @experiment_directories = split (",", $input_experiments); 7278 7279#------------------------------------------------------------------------------ 7280# For every function in the function overview, set up an html structure with 7281# the various hyperlinks. 7282#------------------------------------------------------------------------------ 7283 7284#------------------------------------------------------------------------------ 7285# Core loop that generates an HTML line for each function. 7286#------------------------------------------------------------------------------ 7287 my $top_of_table = $FALSE; 7288 for my $i (0 .. $#function_info) 7289 { 7290 if (defined ($function_info[$i]{"alt_name"})) 7291 { 7292 $target_function = $function_info[$i]{"alt_name"}; 7293 } 7294 else 7295 { 7296 my $msg = "function_info[$i]{\"alt_name\"} is not defined"; 7297 gp_message ("assertion", $subr_name, $msg); 7298 } 7299 7300 $html_source_functions{$target_function} = $function_info[$i]{"html function block"}; 7301 } 7302 7303 for my $i (sort keys %html_source_functions) 7304 { 7305 gp_message ("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}"); 7306 } 7307 7308 $file_title = "Function view for experiments " . $input_experiments; 7309 7310#------------------------------------------------------------------------------ 7311# Example input file: 7312 7313# Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm 7314# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 7315# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 7316# Functions sorted by metric: Exclusive Total CPU Time 7317# 7318# PC Addr. Name Excl. Excl. CPU Excl. Excl. 7319# Total Cycles Instructions Last-Level 7320# CPU sec. sec. Executed Cache Misses 7321# 1:0x00000000 <Total> 3.502 4.005 15396819700 24024250 7322# 2:0x000021ae mxv_core 3.342 3.865 14500538981 23824045 7323# 6:0x0003af50 erand48_r 0.080 0.084 768240570 0 7324# 2:0x00001f7b init_data 0.040 0.028 64020043 200205 7325# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 7326# ... 7327#------------------------------------------------------------------------------ 7328 7329 for my $metric (@sort_fields) 7330 { 7331 $overview_file = $outputdir . $metric . ".sort.func-PC2"; 7332 7333 $exp_type = $metric; 7334 7335 if ($metric eq "functions") 7336 { 7337 $html_function_view .= $g_html_base_file_name{"function_view"} . ".html"; 7338 } 7339 else 7340 { 7341 $html_function_view = $g_html_base_file_name{"function_view"} . "." . $metric . ".html"; 7342 } 7343#------------------------------------------------------------------------------ 7344# The default function view is based upon the first metric in the list. We use 7345# this file in the index.html file. 7346#------------------------------------------------------------------------------ 7347 if ($metric eq $g_first_metric) 7348 { 7349 $html_first_metric_file = $html_function_view; 7350 my $txt = "g_first_metric = $g_first_metric "; 7351 $txt .= "html_first_metric_file = $html_first_metric_file"; 7352 gp_message ("debugXL", $subr_name, $txt); 7353 } 7354 7355 $html_output_file = $outputdir . $html_function_view; 7356 7357 open (FUNCTION_VIEW, ">", $html_output_file) 7358 or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); 7359 gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); 7360 7361 $html_home = ${ generate_home_link ("right") }; 7362 $html_header = ${ create_html_header (\$file_title) }; 7363 7364 $page_title = "Function View"; 7365 $size_text = "h2"; 7366 $position_text = "center"; 7367 $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 7368 7369 print FUNCTION_VIEW $html_header; 7370 print FUNCTION_VIEW $html_home; 7371 print FUNCTION_VIEW $html_title_header; 7372 print FUNCTION_VIEW "$_" for @g_html_experiment_stats; 7373 print FUNCTION_VIEW $html_new_line . "\n"; 7374 7375 my $function_view_structure_ref = process_function_overview ( 7376 \$metric, 7377 \$exp_type, 7378 \$summary_metrics, 7379 \$number_of_metrics, 7380 \@function_info, 7381 \%function_view_structure, 7382 \$overview_file); 7383 7384 my %function_view_structure = %{ $function_view_structure_ref }; 7385 7386#------------------------------------------------------------------------------ 7387# Core part: extract the true function name and find the html code for it. 7388#------------------------------------------------------------------------------ 7389 gp_message ("debugXL", $subr_name, "the final table"); 7390 7391 print FUNCTION_VIEW "<pre>\n"; 7392 print FUNCTION_VIEW "$_\n" for @{ $function_view_structure{"header"} }; 7393 7394 my $max_length_header = $function_view_structure{"max header length"}; 7395 my $max_length_metrics = $function_view_structure{"max metrics length"}; 7396 7397#------------------------------------------------------------------------------ 7398# Add 4 more spaces for the distance to the function names. Purely cosmetic. 7399#------------------------------------------------------------------------------ 7400 my $pad = max ($max_length_metrics, $max_length_header) + 4; 7401 my $spaces = ""; 7402 for my $i (1 .. $pad) 7403 { 7404 $spaces .= " "; 7405 } 7406 7407#------------------------------------------------------------------------------ 7408# Add extra space for the /blank/*/ marker! 7409#------------------------------------------------------------------------------ 7410 $spaces .= " "; 7411 my $func_header = $spaces . $function_view_structure{"table name"}; 7412 gp_message ("debugXL", $subr_name, "func_header = " . $func_header); 7413 7414 print FUNCTION_VIEW $spaces . "<b>" . 7415 $function_view_structure{"table name"} . 7416 "</b>" . $html_new_line . "\n"; 7417 7418#------------------------------------------------------------------------------ 7419# If the header is longer than the metrics, add spaces to padd the difference. 7420# Also add the same 4 spaces between the metric values and the function name. 7421#------------------------------------------------------------------------------ 7422 $pad = 0; 7423 if ($max_length_header > $max_length_metrics) 7424 { 7425 $pad = $max_length_header - $max_length_metrics; 7426 } 7427 $pad += 4; 7428 $spaces = ""; 7429 for my $i (1 .. $pad) 7430 { 7431 $spaces .= " "; 7432 } 7433 7434#------------------------------------------------------------------------------ 7435# This is where it literally all comes together. The metrics and function 7436# parts are combined. 7437#------------------------------------------------------------------------------ 7438## for my $i (keys @{ $function_view_structure{"function table"} }) 7439 for my $i (0 .. $#{ $function_view_structure{"function table"} }) 7440 { 7441 my $p1 = $function_view_structure{"metrics part"}[$i]; 7442 my $p2 = $function_view_structure{"function table"}[$i]; 7443 7444 $full_index_line = $p1 . $spaces . $p2; 7445 7446 push (@full_function_view_line, $full_index_line); 7447 } 7448 7449 print FUNCTION_VIEW "$_\n" for @full_function_view_line; 7450 7451#------------------------------------------------------------------------------ 7452# Clear the array before filling it up again. 7453#------------------------------------------------------------------------------ 7454 @full_function_view_line = (); 7455 7456#------------------------------------------------------------------------------ 7457# Get the acknowledgement, return to main link, and final html statements. 7458#------------------------------------------------------------------------------ 7459 $html_home = ${ generate_home_link ("left") }; 7460 $html_acknowledgement = ${ create_html_credits () }; 7461 $html_end = ${ terminate_html_document () }; 7462 7463 print FUNCTION_VIEW "</pre>\n"; 7464 print FUNCTION_VIEW $html_home; 7465 print FUNCTION_VIEW $html_new_line . "\n"; 7466 print FUNCTION_VIEW $html_acknowledgement; 7467 print FUNCTION_VIEW $html_end; 7468 7469 close (FUNCTION_VIEW); 7470 } 7471 7472 return (\$html_first_metric_file); 7473 7474} #-- End of subroutine generate_function_view 7475 7476#------------------------------------------------------------------------------ 7477# Generate an html line that links back to index.html. The text can either 7478# be positioned to the left or to the right. 7479#------------------------------------------------------------------------------ 7480sub generate_home_link 7481{ 7482 my $subr_name = get_my_name (); 7483 7484 my ($which_side) = @_; 7485 7486 my $html_home_line; 7487 7488 if (($which_side ne "left") and ($which_side ne "right")) 7489 { 7490 my $msg = "which_side = $which_side not supported"; 7491 gp_message ("assertion", $subr_name, $msg); 7492 } 7493 7494 $html_home_line .= "<div class=\"" . $which_side . "\">"; 7495 $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"}; 7496 $html_home_line .= ".html' style='background-color:"; 7497 $html_home_line .= $g_html_color_scheme{"index"}; 7498 $html_home_line .= "'><b>Return to main view</b></a>"; 7499 $html_home_line .= "</div>"; 7500 7501 return (\$html_home_line); 7502 7503} #-- End of subroutine generate_home_link 7504 7505#------------------------------------------------------------------------------ 7506# Generate a block of html for this function block. 7507#------------------------------------------------------------------------------ 7508sub generate_html_function_blocks 7509{ 7510 my $subr_name = get_my_name (); 7511 7512 my ( 7513 $index_start_ref, 7514 $index_end_ref, 7515 $hex_addresses_ref, 7516 $the_metrics_ref, 7517 $length_first_metric_ref, 7518 $special_marker_ref, 7519 $the_function_name_ref, 7520 $separator_ref, 7521 $number_of_metrics_ref, 7522 $data_function_block_ref, 7523 $function_info_ref, 7524 $function_view_structure_ref) = @_; 7525 7526 my $index_start = ${ $index_start_ref }; 7527 my $index_end = ${ $index_end_ref }; 7528 my @hex_addresses = @{ $hex_addresses_ref }; 7529 my @the_metrics = @{ $the_metrics_ref }; 7530 my @length_first_metric = @{ $length_first_metric_ref }; 7531 my @special_marker = @{ $special_marker_ref }; 7532 my @the_function_name = @{ $the_function_name_ref}; 7533 7534 my $separator = ${ $separator_ref }; 7535 my $number_of_metrics = ${ $number_of_metrics_ref }; 7536 my $data_function_block = ${ $data_function_block_ref }; 7537 my @function_info = @{ $function_info_ref }; 7538 my %function_view_structure = %{ $function_view_structure_ref }; 7539 7540 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 7541 7542 my @html_block_prologue = (); 7543 my @html_code_function_block = (); 7544 my @function_lines = (); 7545 my @fields = (); 7546 my @address_field = (); 7547 my @metric_values = (); 7548 my @function_names = (); 7549 my @final_function_names = (); 7550 my @marker = (); 7551 my @split_number = (); 7552 my @function_tags = (); 7553 7554 my $all_metrics; 7555 my $current_function_name; 7556 my $no_of_fields; 7557 my $name_regex; 7558 my $full_hex_address; 7559 my $hex_address; 7560 my $target_function; 7561 my $marker_function; 7562 my $routine; 7563 my $routine_length; 7564 my $metrics_length; 7565 my $max_metrics_length = 0; 7566 my $modified_line; 7567 my $string_length; 7568 my $addr_offset; 7569 my $current_address; 7570 my $found_a_match; 7571 my $ref_index; 7572 my $alt_name; 7573 my $length_first_field; 7574 my $gap; 7575 my $ipad; 7576 my $html_line; 7577 my $target_tag; 7578 my $tag_for_header; 7579 my $href_file; 7580 my $found_alt_name; 7581 my $name_in_header; 7582 my $create_hyperlinks; 7583 7584 state $first_call = $TRUE; 7585 state $reference_length; 7586 7587#------------------------------------------------------------------------------ 7588# If the length of the first metric is less than the maximum over all first 7589# metrics, add spaces to the left to ensure correct alignment. 7590#------------------------------------------------------------------------------ 7591 for my $k ($index_start .. $index_end) 7592 { 7593 my $pad = $g_max_length_first_metric - $length_first_metric[$k]; 7594 if ($pad ge 1) 7595 { 7596 my $spaces = ""; 7597 for my $s (1 .. $pad) 7598 { 7599 $spaces .= " "; 7600 } 7601 $the_metrics[$k] = $spaces . $the_metrics[$k]; 7602 7603 my $msg = "padding spaces = $spaces the_metrics[$k] = $the_metrics[$k]"; 7604 gp_message ("debugXL", $subr_name, $msg); 7605 } 7606 7607## my $end_game = "end game3=> pad = $pad" . $hex_addresses[$k] . " " . $the_metrics[$k] . " " . $special_marker[$k] . $the_function_name[$k]; 7608## gp_message ("debugXL", $subr_name, $end_game); 7609 } 7610 7611#------------------------------------------------------------------------------ 7612# An example what @function_lines should look like after the split: 7613# <empty> 7614# 6:0x0003ad20 drand48 0.100 0.084 768240570 0 7615# 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0 7616# 6:0x0003b160 __drand48_iterate 0.020 0. 0 0 7617#------------------------------------------------------------------------------ 7618 @function_lines = split ($separator, $data_function_block); 7619 7620#------------------------------------------------------------------------------ 7621# Parse the individual lines. Replace multi-occurrence functions by their 7622# unique alternative name and mark the target function. 7623# 7624# The above split operation produces an empty first field because the line 7625# starts with the separator. This is why skip the first field. 7626#------------------------------------------------------------------------------ 7627 for my $i ($index_start .. $index_end) 7628 { 7629 my $input_line = $the_metrics[$i]; 7630 7631 gp_message ("debugXL", $subr_name, "the_metrics[$i] = ". $the_metrics[$i]); 7632 7633#------------------------------------------------------------------------------ 7634# In case the last metric is 0. only, we append 3 extra characters that 7635# represent zero. We cannot change the number to 0.000 though because that 7636# has a different interpretation than 0. 7637# In a later phase, the "ZZZ" symbol will be removed again, but for now it 7638# creates consistency in, for example, the length of the metrics part. 7639#------------------------------------------------------------------------------ 7640 if ($input_line =~ /[\w0-9$decimal_separator]*(0$decimal_separator$)/) 7641 { 7642 if (defined ($1) ) 7643 { 7644 my $decimal_point = $decimal_separator; 7645 $decimal_point =~ s/\\//; 7646 my $txt = "input_line = $input_line = ended with 0"; 7647 $txt .= $decimal_point; 7648 gp_message ("debugXL", $subr_name, $txt); 7649 7650 $the_metrics[$i] .= "ZZZ"; 7651 } 7652 } 7653 7654 $hex_address = $hex_addresses[$i]; 7655 $marker_function = $special_marker[$i]; 7656 $routine = $the_function_name[$i]; 7657#------------------------------------------------------------------------------ 7658# Get the length of the metrics line before ZZZ is replaced by spaces. 7659#------------------------------------------------------------------------------ 7660 $all_metrics = $the_metrics[$i]; 7661 $metrics_length = length ($all_metrics); 7662 $all_metrics =~ s/ZZZ/ /g; 7663 7664 $max_metrics_length = max ($max_metrics_length, $metrics_length); 7665 7666 push (@marker, $marker_function); 7667 push (@address_field, $hex_address); 7668 push (@metric_values, $all_metrics); 7669 push (@function_names, $routine); 7670 7671 my $index_into_function_info_ref = get_index_function_info ( 7672 \$routine, 7673 \$hex_addresses[$i], 7674 $function_info_ref); 7675 7676 my $index_into_function_info = ${ $index_into_function_info_ref }; 7677 $target_tag = $function_info[$index_into_function_info]{"tag_id"}; 7678 $alt_name = $function_info[$index_into_function_info]{"alt_name"}; 7679 7680#------------------------------------------------------------------------------ 7681# Keep the name of the target function (the one marked with a *) for later use. 7682# This is the tag that identifies the block in the caller-callee output. The 7683# tag is used in the link to the caller-callee in the function overview. 7684#------------------------------------------------------------------------------ 7685 if ($marker_function eq "*") 7686 { 7687 $tag_for_header = $target_tag; 7688 $name_in_header = $alt_name; 7689 7690#------------------------------------------------------------------------------ 7691# We need to replace the "<" symbol in the code by "<". 7692#------------------------------------------------------------------------------ 7693 $name_in_header =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 7694 7695 } 7696 push (@final_function_names, $alt_name); 7697 push (@function_tags, $target_tag); 7698 7699 gp_message ("debugXL", $subr_name, "index_into_function_info = $index_into_function_info"); 7700 gp_message ("debugXL", $subr_name, "target_tag = $target_tag"); 7701 gp_message ("debugXL", $subr_name, "alt_name = $alt_name"); 7702 7703 } #-- End of loop for my $i ($index_start .. $index_end) 7704 7705 my $tag_line = "<a id='" . $tag_for_header . "'></a>"; 7706 $html_line = "<br>\n"; 7707 $html_line .= $tag_line . "Function name: "; 7708 $html_line .= "<span style='color:" . $g_html_color_scheme{"target_function_name"} . "'>"; 7709 $html_line .= "<b>" . $name_in_header . "</b></span>\n"; 7710 $html_line .= "<br>"; 7711 7712 push (@html_block_prologue, $html_line); 7713 7714 gp_message ("debugXL", $subr_name, "the final function block for $name_in_header"); 7715 7716 $href_file = $g_html_base_file_name{"caller_callee"} . ".html"; 7717 7718#------------------------------------------------------------------------------ 7719# Process the function blocks and generate the HTML structure for them. 7720#------------------------------------------------------------------------------ 7721 for my $i (0 .. $#final_function_names) 7722 { 7723 $current_function_name = $final_function_names[$i]; 7724 gp_message ("debugXL", $subr_name, "current_function_name = $current_function_name"); 7725 7726#------------------------------------------------------------------------------ 7727# Do not add hyperlinks for <Total>. 7728#------------------------------------------------------------------------------ 7729 if ($current_function_name eq "<Total>") 7730 { 7731 $create_hyperlinks = $FALSE; 7732 } 7733 else 7734 { 7735 $create_hyperlinks = $TRUE; 7736 } 7737 7738#------------------------------------------------------------------------------ 7739# We need to replace the "<" symbol in the code by "<". 7740#------------------------------------------------------------------------------ 7741 $current_function_name =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 7742 7743 $html_line = $metric_values[$i] . " "; 7744 7745 if ($marker[$i] eq "*") 7746 { 7747 $current_function_name = "<b>" . $current_function_name . "</b>"; 7748 } 7749 $html_line .= " <a href='" . $href_file . "#" . $function_tags[$i] . "'>" . $current_function_name . "</a>"; 7750 7751 if ($marker[$i] eq "*") 7752 { 7753 $html_line = "<br>" . $html_line; 7754 } 7755 elsif (($marker[$i] ne "*") and ($i == 0)) 7756 { 7757 $html_line = "<br>" . $html_line; 7758 } 7759 7760 gp_message ("debugXL", $subr_name, "html_line = $html_line"); 7761 7762#------------------------------------------------------------------------------ 7763# Find the index into "function_info" for this particular function. 7764#------------------------------------------------------------------------------ 7765 $routine = $function_names[$i]; 7766 $current_address = $address_field[$i]; 7767 7768 my $target_index_ref = find_index_in_function_info (\$routine, \$current_address, \@function_info); 7769 my $target_index = ${ $target_index_ref }; 7770 7771 gp_message ("debugXL", $subr_name, "routine = $routine current_address = $current_address target_index = $target_index"); 7772 7773#------------------------------------------------------------------------------ 7774# TBD Do this once for each function and store the result. This is a saving 7775# because functions may and typically will appear more than once. 7776#------------------------------------------------------------------------------ 7777 my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"}; 7778 7779#------------------------------------------------------------------------------ 7780# Add the links to the line. Make sure there is at least one space. 7781#------------------------------------------------------------------------------ 7782 my $spaces = " "; 7783 for my $k (1 .. $spaces_left) 7784 { 7785 $spaces .= " "; 7786 } 7787 7788 if ($create_hyperlinks) 7789 { 7790 $html_line .= $spaces; 7791 $html_line .= $function_info[$target_index]{"href_source"}; 7792 $html_line .= " "; 7793 $html_line .= $function_info[$target_index]{"href_disassembly"}; 7794 } 7795 7796 push (@html_code_function_block, $html_line); 7797 } 7798 7799 for my $lines (0 .. $#html_code_function_block) 7800 { 7801 gp_message ("debugXL", $subr_name, "final html block = " . $html_code_function_block[$lines]); 7802 } 7803 7804 return (\@html_block_prologue, \@html_code_function_block); 7805 7806} #-- End of subroutine generate_html_function_blocks 7807 7808#------------------------------------------------------------------------------ 7809# Get all the metrics available 7810# 7811# (gp-display-text) metric_list 7812# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name 7813# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 7814# Available metrics: 7815# Exclusive Total CPU Time: e.%totalcpu 7816# Inclusive Total CPU Time: i.%totalcpu 7817# Exclusive CPU Cycles: e.+%cycles 7818# Inclusive CPU Cycles: i.+%cycles 7819# Exclusive Instructions Executed: e+%insts 7820# Inclusive Instructions Executed: i+%insts 7821# Exclusive Last-Level Cache Misses: e+%llm 7822# Inclusive Last-Level Cache Misses: i+%llm 7823# Exclusive Instructions Per Cycle: e+IPC 7824# Inclusive Instructions Per Cycle: i+IPC 7825# Exclusive Cycles Per Instruction: e+CPI 7826# Inclusive Cycles Per Instruction: i+CPI 7827# Size: size 7828# PC Address: address 7829# Name: name 7830#------------------------------------------------------------------------------ 7831sub get_all_the_metrics 7832{ 7833 my $subr_name = get_my_name (); 7834 7835 my ($experiments_ref, $outputdir_ref) = @_; 7836 7837 my $experiments = ${ $experiments_ref }; 7838 my $outputdir = ${ $outputdir_ref }; 7839 7840 my $ignore_value; 7841 my $gp_functions_cmd; 7842 my $gp_display_text_cmd; 7843 7844 my $metrics_output_file = $outputdir . "metrics-all"; 7845 my $result_file = $outputdir . $g_gp_output_file; 7846 my $gp_error_file = $outputdir . $g_gp_error_logfile; 7847 my $script_file_metrics = $outputdir . "script-metrics"; 7848 7849 my @metrics_data = (); 7850 7851 open (SCRIPT_METRICS, ">", $script_file_metrics) 7852 or die ("$subr_name - unable to open script file $script_file_metrics for writing: '$!'"); 7853 gp_message ("debug", $subr_name, "opened script file $script_file_metrics for writing"); 7854 7855 print SCRIPT_METRICS "# outfile $metrics_output_file\n"; 7856 print SCRIPT_METRICS "outfile $metrics_output_file\n"; 7857 print SCRIPT_METRICS "# metric_list\n"; 7858 print SCRIPT_METRICS "metric_list\n"; 7859 7860 close (SCRIPT_METRICS); 7861 7862 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file_metrics $experiments"; 7863 7864 gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get all the metrics"); 7865 7866 $gp_display_text_cmd = "$gp_functions_cmd 1>> $result_file 2>> $gp_error_file"; 7867 gp_message ("debug", $subr_name, "cmd = $gp_display_text_cmd"); 7868 7869 my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 7870 7871 if ($error_code != 0) 7872 { 7873 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 7874 $error_code, 7875 $gp_error_file); 7876 gp_message ("abort", $subr_name, "execution terminated"); 7877 } 7878 7879 open (METRICS_INFO, "<", $metrics_output_file) 7880 or die ("$subr_name - unable to open file $metrics_output_file for reading '$!'"); 7881 gp_message ("debug", $subr_name, "opened file $metrics_output_file for reading"); 7882 7883#------------------------------------------------------------------------------ 7884# Read the input file into memory. 7885#------------------------------------------------------------------------------ 7886 chomp (@metrics_data = <METRICS_INFO>); 7887 gp_message ("debug", $subr_name, "read all contents of file $metrics_output_file into memory"); 7888 gp_message ("debug", $subr_name, "\$#metrics_data = $#metrics_data"); 7889 7890 my $input_line; 7891 my $ignore_lines_regex = '^(?:Current|Available|\s+Size:|\s+PC Address:|\s+Name:)'; 7892 my $split_line_regex = '(.*): (.*)'; 7893 my $empty_line_regex = '^\s*$'; 7894 my @metric_list_all = (); 7895 for (my $line_no=0; $line_no <= $#metrics_data; $line_no++) 7896 { 7897 7898 $input_line = $metrics_data[$line_no]; 7899 7900## if ( not (($input_line =~ /$ignore_lines_regex/ or ($input_line =~ /^\s*$/)))) 7901 if ( not ($input_line =~ /$ignore_lines_regex/) and not ($input_line =~ /$empty_line_regex/) ) 7902 { 7903 if ($input_line =~ /$split_line_regex/) 7904 { 7905#------------------------------------------------------------------------------ 7906# Remove the percentages. 7907#------------------------------------------------------------------------------ 7908 my $metric_definition = $2; 7909 $metric_definition =~ s/\%//g; 7910 gp_message ("debug", $subr_name, "line_no = $line_no $metrics_data[$line_no] metric_definition = $metric_definition"); 7911 push (@metric_list_all, $metric_definition); 7912 } 7913 } 7914 7915 } 7916 7917 gp_message ("debug", $subr_name, "\@metric_list_all = @metric_list_all"); 7918 7919 my $final_list = join (":", @metric_list_all); 7920 gp_message ("debug", $subr_name, "final_list = $final_list"); 7921 7922 close (METRICS_INFO); 7923 7924 return (\$final_list); 7925 7926} #-- End of subroutine get_all_the_metrics 7927 7928#------------------------------------------------------------------------------ 7929# A simple function to return the basename using fileparse. To keep things 7930# simple, a suffixlist is not supported. In case this is needed, use the 7931# fileparse function directly. 7932#------------------------------------------------------------------------------ 7933sub get_basename 7934{ 7935 my ($full_name) = @_; 7936 7937 my $ignore_value_1; 7938 my $ignore_value_2; 7939 my $basename_value; 7940 7941 ($basename_value, $ignore_value_1, $ignore_value_2) = fileparse ($full_name); 7942 7943 return ($basename_value); 7944 7945} #-- End of subroutine get_basename 7946 7947#------------------------------------------------------------------------------ 7948# Get the details on the experiments and store these in a file. Each 7949# experiment has its own file. This makes the processing easier. 7950#------------------------------------------------------------------------------ 7951sub get_experiment_info 7952{ 7953 my $subr_name = get_my_name (); 7954 7955 my ($outputdir_ref, $exp_dir_list_ref) = @_; 7956 7957 my $outputdir = ${ $outputdir_ref }; 7958 my @exp_dir_list = @{ $exp_dir_list_ref }; 7959 7960 my $cmd_output; 7961 my $current_slot; 7962 my $error_code; 7963 my $exp_info_file; 7964 my @exp_info = (); 7965 my @experiment_data = (); 7966 my $gp_error_file; 7967 my $gp_display_text_cmd; 7968 my $gp_functions_cmd; 7969 my $gp_log_file; 7970 my $ignore_value; 7971 my $msg; 7972 my $overview_file; 7973 my $result_file; 7974 my $script_file; 7975 my $the_experiments; 7976 7977 $the_experiments = join (" ", @exp_dir_list); 7978 7979 $script_file = $outputdir . "gp-info-exp.script"; 7980 $exp_info_file = $outputdir . "gp-info-exp-list.out"; 7981 $overview_file = $outputdir . "gp-overview.out"; 7982 $gp_log_file = $outputdir . $g_gp_output_file; 7983 $gp_error_file = $outputdir . $g_gp_error_logfile; 7984 7985 open (SCRIPT_EXPERIMENT_INFO, ">", $script_file) 7986 or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); 7987 gp_message ("debug", $subr_name, "opened script file $script_file for writing"); 7988 7989#------------------------------------------------------------------------------ 7990# Attributed User CPU Time=a.user : for calltree - see P37 in manual 7991#------------------------------------------------------------------------------ 7992 print SCRIPT_EXPERIMENT_INFO "# compare on\n"; 7993 print SCRIPT_EXPERIMENT_INFO "compare on\n"; 7994 print SCRIPT_EXPERIMENT_INFO "# outfile $exp_info_file\n"; 7995 print SCRIPT_EXPERIMENT_INFO "outfile $exp_info_file\n"; 7996 print SCRIPT_EXPERIMENT_INFO "# exp_list\n"; 7997 print SCRIPT_EXPERIMENT_INFO "exp_list\n"; 7998 print SCRIPT_EXPERIMENT_INFO "# outfile $overview_file\n"; 7999 print SCRIPT_EXPERIMENT_INFO "outfile $overview_file\n"; 8000 print SCRIPT_EXPERIMENT_INFO "# overview\n"; 8001 print SCRIPT_EXPERIMENT_INFO "overview\n"; 8002 8003 close SCRIPT_EXPERIMENT_INFO; 8004 8005 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments"; 8006 8007 gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment information"); 8008 8009 $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file"; 8010 8011 ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 8012 8013 if ($error_code != 0) 8014 { 8015 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 8016 $error_code, 8017 $gp_error_file); 8018 gp_message ("abort", $subr_name, "execution terminated"); 8019 } 8020 8021#------------------------------------------------------------------------------ 8022# The first file has the following format: 8023# 8024# ID Sel PID Experiment 8025# == === ======= ====================================================== 8026# 1 yes 2078714 <absolute_path/mxv.hwc.1.thr.er 8027# 2 yes 2078719 <absolute_path/mxv.hwc.2.thr.er 8028#------------------------------------------------------------------------------ 8029 open (EXP_INFO, "<", $exp_info_file) 8030 or die ("$subr_name - unable to open file $exp_info_file for reading '$!'"); 8031 gp_message ("debug", $subr_name, "opened script file $exp_info_file for reading"); 8032 8033 chomp (@exp_info = <EXP_INFO>); 8034 8035#------------------------------------------------------------------------------ 8036# TBD - Check for the groups to exist below: 8037#------------------------------------------------------------------------------ 8038 $current_slot = 0; 8039 for my $i (0 .. $#exp_info) 8040 { 8041 my $input_line = $exp_info[$i]; 8042 8043 gp_message ("debug", $subr_name, "$i => exp_info[$i] = $exp_info[$i]"); 8044 8045 if ($input_line =~ /^\s*(\d+)\s+(.+)/) 8046 { 8047 my $exp_id = $1; 8048 my $remainder = $2; 8049 $experiment_data[$current_slot]{"exp_id"} = $exp_id; 8050 $experiment_data[$current_slot]{"exp_data_file"} = $outputdir . "gp-info-exp-" . $exp_id . ".out"; 8051 gp_message ("debug", $subr_name, $i . " " . $exp_id . " " . $remainder); 8052 if ($remainder =~ /^(\w+)\s+(\d+)\s+(.+)/) 8053 { 8054 my $exp_name = $3; 8055 $experiment_data[$current_slot]{"exp_name_full"} = $exp_name; 8056 $experiment_data[$current_slot]{"exp_name_short"} = get_basename ($exp_name); 8057 $current_slot++; 8058 gp_message ("debug", $subr_name, $i . " " . $1 . " " . $2 . " " . $3); 8059 } 8060 else 8061 { 8062 $msg = "remainder = $remainder has an unexpected format"; 8063 gp_message ("assertion", $subr_name, $msg); 8064 } 8065 } 8066 } 8067#------------------------------------------------------------------------------ 8068# The experiment IDs and names are known. We can now generate the info for 8069# each individual experiment. 8070#------------------------------------------------------------------------------ 8071 $gp_log_file = $outputdir . $g_gp_output_file; 8072 $gp_error_file = $outputdir . $g_gp_error_logfile; 8073 8074 $script_file = $outputdir . "gp-details-exp.script"; 8075 8076 open (SCRIPT_EXPERIMENT_DETAILS, ">", $script_file) 8077 or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); 8078 gp_message ("debug", $subr_name, "opened script file $script_file for writing"); 8079 8080 for my $i (sort keys @experiment_data) 8081 { 8082 my $exp_id = $experiment_data[$i]{"exp_id"}; 8083 8084 $result_file = $experiment_data[$i]{"exp_data_file"}; 8085 8086# statistics 8087# header 8088 print SCRIPT_EXPERIMENT_DETAILS "# outfile " . $result_file . "\n"; 8089 print SCRIPT_EXPERIMENT_DETAILS "outfile " . $result_file . "\n"; 8090 print SCRIPT_EXPERIMENT_DETAILS "# header " . $exp_id . "\n"; 8091 print SCRIPT_EXPERIMENT_DETAILS "header " . $exp_id . "\n"; 8092 print SCRIPT_EXPERIMENT_DETAILS "# statistics " . $exp_id . "\n"; 8093 print SCRIPT_EXPERIMENT_DETAILS "statistics " . $exp_id . "\n"; 8094 8095 } 8096 8097 close (SCRIPT_EXPERIMENT_DETAILS); 8098 8099 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments"; 8100 8101 $msg = "executing $GP_DISPLAY_TEXT to get the experiment details"; 8102 gp_message ("debug", $subr_name, $msg); 8103 8104 $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file"; 8105 8106 ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 8107 8108 if ($error_code != 0) 8109#------------------------------------------------------------------------------ 8110# This is unlikely to happen, but you never know. 8111#------------------------------------------------------------------------------ 8112 { 8113 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 8114 $error_code, 8115 $gp_error_file); 8116 gp_message ("abort", $subr_name, "execution terminated"); 8117 } 8118 8119 return (\@experiment_data); 8120 8121} #-- End of subroutine get_experiment_info 8122 8123#------------------------------------------------------------------------------ 8124# This subroutine returns a string of the type "size=<n>", where <n> is the 8125# size of the file passed in. If n > 1024, a unit is appended. 8126#------------------------------------------------------------------------------ 8127sub getfilesize 8128{ 8129 my $subr_name = get_my_name (); 8130 8131 my ($filename) = @_; 8132 8133 my $size; 8134 my $file_stat; 8135 8136 if (not -e $filename) 8137 { 8138#------------------------------------------------------------------------------ 8139# The return value is used in the caller. This is why we return the empty 8140# string in case the file does not exist. 8141#------------------------------------------------------------------------------ 8142 gp_message ("debug", $subr_name, "filename = $filename not found"); 8143 return (""); 8144 } 8145 else 8146 { 8147 $file_stat = stat ($filename); 8148 $size = $file_stat->size; 8149 8150 gp_message ("debug", $subr_name, "filename = $filename"); 8151 gp_message ("debug", $subr_name, "size = $size"); 8152 8153 if ($size > 1024) 8154 { 8155 if ($size > 1024*1024) 8156 { 8157 $size = $size/1024/1024; 8158 $size =~ s/\..*//; 8159 $size = $size."MB"; 8160 } 8161 else 8162 { 8163 $size = $size/1024; 8164 $size =~ s/\..*//; 8165 $size = $size."KB"; 8166 } 8167 } 8168 else 8169 { 8170 $size=$size." bytes"; 8171 } 8172 gp_message ("debug", $subr_name, "size = $size title=\"$size\""); 8173 8174 return ("title=\"$size\""); 8175 } 8176 8177} #-- End of subroutine getfilesize 8178 8179#------------------------------------------------------------------------------ 8180# Parse the fsummary output and for all functions, store all the information 8181# found in "function_info". In addition to this, several derived structures 8182# are stored as well, making this structure a "onestop" place to get all the 8183# info that is needed. 8184#------------------------------------------------------------------------------ 8185sub get_function_info 8186{ 8187 my $subr_name = get_my_name (); 8188 8189 my ($FSUMMARY_FILE) = @_; 8190 8191#------------------------------------------------------------------------------ 8192# The regex section. 8193#------------------------------------------------------------------------------ 8194 my $white_space_regex = '\s*'; 8195 8196 my @function_info = (); 8197 my %function_address_and_index = (); 8198 my %LINUX_vDSO = (); 8199 my %function_view_structure = (); 8200 my %addressobjtextm = (); 8201#------------------------------------------------------------------------------ 8202# TBD: This structure is no longer used and most likely can be removed. 8203#------------------------------------------------------------------------------ 8204 my %functions_index = (); 8205 8206 my $msg; 8207 8208# TBD: check 8209 my $full_address_field; 8210 my %source_files = (); 8211 8212 my $i; 8213 my $line; 8214 my $routine_flag; 8215 my $value; 8216 my $field; 8217 my $df_flag; 8218 my $address_decimal; 8219 my $routine; 8220 8221 my $num_source_files = 0; 8222 my $number_of_unique_functions = 0; 8223 my $number_of_non_unique_functions = 0; 8224 8225 my $function_info_regex = '\s*(\S+[a-zA-Z\s]*):(.*)'; 8226 my $get_hex_address_regex = '(\d+):(0x\S+)'; 8227#------------------------------------------------------------------------------ 8228# Open the file generated using the -fsummary option. 8229#------------------------------------------------------------------------------ 8230 $msg = " - unable to open file $FSUMMARY_FILE for reading:"; 8231 open (FSUMMARY_FILE, "<", $FSUMMARY_FILE) 8232 or die ($subr_name . $msg . " " . $!); 8233 $msg = "opened file $FSUMMARY_FILE for reading"; 8234 gp_message ("debug", $subr_name, $msg); 8235 8236#------------------------------------------------------------------------------ 8237# This is the typical structure of the fsummary output: 8238# 8239# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 8240# Functions sorted by metric: Exclusive Total CPU Time 8241# 8242# <Total> 8243# Exclusive Total CPU Time: 11.538 (100.0%) 8244# Inclusive Total CPU Time: 11.538 (100.0%) 8245# Size: 0 8246# PC Address: 1:0x00000000 8247# Source File: (unknown) 8248# Object File: (unknown) 8249# Load Object: <Total> 8250# Mangled Name: 8251# Aliases: 8252# 8253# a_function_name 8254# Exclusive Total CPU Time: 4.003 ( 34.7%) 8255# Inclusive Total CPU Time: 4.003 ( 34.7%) 8256# Size: 715 8257# PC Address: 2:0x00006c61 8258# Source File: <absolute path to source file> 8259# Object File: <object filename> 8260# Load Object: <executable name> 8261# Mangled Name: 8262# Aliases: 8263# 8264# The previous block is repeated for every function. 8265#------------------------------------------------------------------------------ 8266 8267#------------------------------------------------------------------------------ 8268# Skip the header. The header is defined to end with a blank line. 8269#------------------------------------------------------------------------------ 8270 while (<FSUMMARY_FILE>) 8271 { 8272 $line = $_; 8273 chomp ($line); 8274 if ($line =~ /^\s*$/) 8275 { 8276 last; 8277 } 8278 } 8279 8280#------------------------------------------------------------------------------ 8281# Process the remaining blocks. Note that the first line should be <Total>, 8282# but this is currently not checked. 8283#------------------------------------------------------------------------------ 8284 $i = 0; 8285 $routine_flag = $TRUE; 8286 while (<FSUMMARY_FILE>) 8287 { 8288 $line = $_; 8289 chomp ($line); 8290 8291#------------------------------------------------------------------------------ 8292# Legacy issue to deal with. Up until somewhere between binutils 2.40 and 2.41, 8293# gprofng display text might print the " -- no functions found" comment. 8294# No, the two spaces after -- are not my typo ;-) 8295# 8296# Since then, this comment is no longer printed, but the safe approach is to 8297# remove any occurrence upfront. 8298#------------------------------------------------------------------------------ 8299 $line =~ s/ -- no functions found//; 8300 8301 $msg = "line = " . $line; 8302 gp_message ("debugXL", $subr_name, $msg); 8303 8304 if ($line =~ /^\s*$/) 8305#------------------------------------------------------------------------------ 8306# Blank line. 8307#------------------------------------------------------------------------------ 8308 { 8309 $routine_flag = $TRUE; 8310 $df_flag = 0; 8311 8312#------------------------------------------------------------------------------ 8313# Linux vDSO exception 8314# 8315# TBD: Check if still relevant. 8316#------------------------------------------------------------------------------ 8317 if ($function_info[$i]{"Load Object"} eq "DYNAMIC_FUNCTIONS") 8318 { 8319 $LINUX_vDSO{substr ($function_info[$i]{"addressobjtext"},1)} = $function_info[$i]{"routine"}; 8320 } 8321 $i++; 8322 next; 8323 } 8324 8325 if ($routine_flag) 8326#------------------------------------------------------------------------------ 8327# Should be the first line after the blank line. 8328#------------------------------------------------------------------------------ 8329 { 8330 $routine = $line; 8331 push (@{ $g_map_function_to_index{$routine} }, $i); 8332 gp_message ("debugXL", $subr_name, "pushed i = $i to g_map_function_to_index{$routine}"); 8333 8334#------------------------------------------------------------------------------ 8335# In a later parsing phase we need to know how many fields there are in a 8336# function name. For example, "<static>@0x21850 (<libc-2.28.so>)" is name that 8337# may show up in a function list. 8338# 8339# Here we determine the number of fields and store it. 8340# 8341# REVISIT This may not be needed anymore 8342#------------------------------------------------------------------------------ 8343 my @fields_in_name = split (" ", $routine); 8344 $function_info[$i]{"fields in routine name"} = scalar (@fields_in_name); 8345 8346#------------------------------------------------------------------------------ 8347# This name may change if the function has multiple occurrences, but in any 8348# case, at the end of this routine this component has the final name to be 8349# used. 8350#------------------------------------------------------------------------------ 8351 $function_info[$i]{"alt_name"} = $routine; 8352 if (not exists ($g_function_occurrences{$routine})) 8353 { 8354 gp_message ("debugXL", $subr_name, "the entry in function_info for $routine does not exist"); 8355 $function_info[$i]{"routine"} = $routine; 8356 $g_function_occurrences{$routine} = 1; 8357 8358 gp_message ("debugXL", $subr_name, "g_function_occurrences{$routine} = $g_function_occurrences{$routine}"); 8359 } 8360 else 8361 { 8362 gp_message ("debugXL", $subr_name, "the entry in function_info for $routine exists already"); 8363 $function_info[$i]{"routine"} = $routine; 8364 $g_function_occurrences{$routine} += 1; 8365 if (not exists ($g_multi_count_function{$routine})) 8366 { 8367 $g_multi_count_function{$routine} = $TRUE; 8368 } 8369 $msg = "g_function_occurrences{$routine} = "; 8370 $msg .= $g_function_occurrences{$routine}; 8371 gp_message ("debugXL", $subr_name, $msg); 8372 } 8373#------------------------------------------------------------------------------ 8374# New: used when generating the index. 8375#------------------------------------------------------------------------------ 8376 $function_info[$i]{"function length"} = length ($routine); 8377 $function_info[$i]{"tag_id"} = create_function_tag ($i); 8378 if (not exists ($g_function_tag_id{$routine})) 8379 { 8380 $g_function_tag_id{$routine} = create_function_tag ($i); 8381 } 8382 else 8383 { 8384 8385#------------------------------------------------------------------------------ 8386## TBD HACK!!! CHECK!!!!! 8387#------------------------------------------------------------------------------ 8388 $g_function_tag_id{$routine} = $i; 8389 } 8390 8391 $routine_flag = $FALSE; 8392 gp_message ("debugXL", $subr_name, "stored " . $function_info[$i]{"routine"}); 8393 8394#------------------------------------------------------------------------------ 8395# The $functions_index hash contains an array. After an initial assignment, 8396# other values that have been found are pushed onto the arrays. 8397#------------------------------------------------------------------------------ 8398 if (not exists ($functions_index{$routine})) 8399 { 8400 $functions_index{$routine} = [$i]; 8401 } 8402 else 8403 { 8404#------------------------------------------------------------------------------ 8405# Add the array index to the list 8406#------------------------------------------------------------------------------ 8407 push (@{$functions_index{$routine}}, $i); 8408 } 8409 next; 8410 } 8411 8412#------------------------------------------------------------------------------ 8413# Example format of an input block, where $line is one of the following: 8414# Exclusive Total CPU Time: 0.001 ( 0.0%) 8415# Inclusive Total CPU Time: 0.001 ( 0.0%) 8416# Size: 92 8417# PC Address: 5:0x00125de0 8418# Source File: (unknown) 8419# Object File: (unknown) 8420# Load Object: /usr/lib64/libc-2.28.so 8421# Mangled Name: 8422# Aliases: __brk 8423#------------------------------------------------------------------------------ 8424 $line =~ s/^\s+//; 8425 if ($line =~ /$function_info_regex/) 8426 { 8427 if (defined ($1) and defined($2)) 8428 { 8429 $field = $1; 8430 $value = $2; 8431 $value =~ s/$g_rm_surrounding_spaces_regex//g; 8432 8433 $msg = "initial - field = " . $field . " value = " . $value; 8434 gp_message ("debugM", $subr_name, $msg); 8435 } 8436 else 8437 { 8438 $msg = "the input line pattern was not recognized"; 8439 gp_message ("warning", $subr_name, $msg); 8440 gp_message ("debug", $subr_name, $msg); 8441 $msg = "execution continues, but there may be a problem later"; 8442 gp_message ("warning", $subr_name, $msg); 8443 gp_message ("debug", $subr_name, $msg); 8444 8445 $field = "not recognized"; 8446 $value = "not recognized"; 8447 } 8448#------------------------------------------------------------------------------ 8449# The field has no value. 8450#------------------------------------------------------------------------------ 8451 if (length ($value) eq 0) 8452## if ($value =~ /^\s+$/) 8453## if (length ($2) gt 0) 8454## if ($2 == " ") 8455 { 8456 if ($field eq "Mangled Name") 8457 { 8458 $value = $routine; 8459 8460 $msg = "no mangled name found - use the routine name "; 8461 $msg .= $routine . " as the mangled name"; 8462 gp_message ("debugM", $subr_name, $msg); 8463 } 8464 else 8465 { 8466 $value = "no_value_given"; 8467 8468 $msg = "no value was found for this field - set to "; 8469 $msg .= $value; 8470 gp_message ("debugM", $subr_name, $msg); 8471 } 8472 } 8473#------------------------------------------------------------------------------ 8474# Remove any leading whitespace characters. 8475#------------------------------------------------------------------------------ 8476 $value =~ s/$white_space_regex//; 8477#------------------------------------------------------------------------------ 8478# These are the final values that will be used. 8479#------------------------------------------------------------------------------ 8480 $msg = "final - field = " . $field . " value = " . $value; 8481 gp_message ("debugM", $subr_name, $msg); 8482 8483 $function_info[$i]{$field} = $value; 8484 } 8485## $value =~ s/$white_space_regex//; 8486 8487## \s*(\S+[a-zA-Z\s]*):\ *(.*) 8488 8489### my @input_fields = split (":", $line); 8490### my $no_of_elements = scalar (@input_fields); 8491 8492### gp_message ("debugXL", $subr_name, "#input_fields = $#input_fields"); 8493### gp_message ("debugXL", $subr_name, "no_of_elements = $no_of_elements"); 8494### gp_message ("debugXL", $subr_name, "input_fields[0] = $input_fields[0]"); 8495 8496### if ($no_of_elements == 1) 8497#------------------------------------------------------------------------------ 8498# No value 8499#------------------------------------------------------------------------------ 8500### { 8501### $whatever = $input_fields[0]; 8502### $value = ""; 8503### } 8504### elsif ($no_of_elements == 2) 8505### { 8506### #------------------------------------------------------------------------------ 8507### # Note that $value may consist of multiple fields (e.g. 1.651 ( 95.4%)). 8508### #------------------------------------------------------------------------------ 8509### $whatever = $input_fields[0]; 8510### $value = $input_fields[1]; 8511### } 8512### elsif ($no_of_elements == 3) 8513### { 8514### $whatever = $input_fields[0]; 8515### if ($whatever eq "PC Address") 8516### #------------------------------------------------------------------------------ 8517### # Must be an address field. Restore the second colon. 8518### #------------------------------------------------------------------------------ 8519### { 8520### $value = $input_fields[1] . ":" . $input_fields[2]; 8521### } 8522### elsif ($whatever eq "Mangled Name") 8523### #------------------------------------------------------------------------------ 8524### # The mangled name includes a colon (:). Just copy the entire string. 8525### #------------------------------------------------------------------------------ 8526### { 8527### $value = $input_fields[2]; 8528### } 8529### } 8530### else 8531### { 8532### if ($whatever eq "Aliases") 8533### #------------------------------------------------------------------------------ 8534### # The mangled name includes a colon (:). Just copy the entire string. 8535### #------------------------------------------------------------------------------ 8536### { 8537### $value = $input_fields[2]; 8538### } 8539### else 8540### { 8541### $msg = "input line = " . $line; 8542### gp_message ("debug", $subr_name, $msg); 8543### for my $i (keys @input_fields) 8544### { 8545### $msg = "input_fields[$i] = " . $input_fields[$i]; 8546### gp_message ("debug", $subr_name, $msg); 8547### } 8548### $msg = "unexpected input: number of fields = " . $no_of_elements; 8549### gp_message ("debug", $subr_name, $msg); 8550### ## gp_message ("assertion", $subr_name, $msg); 8551### } 8552### } 8553## $function_info[$i]{$field} = $value; 8554 8555#------------------------------------------------------------------------------ 8556# TBD: Seems to be not used anymore and can most likely be removed. Check this. 8557#------------------------------------------------------------------------------ 8558 if ($field =~ /Source File/) 8559 { 8560 if (!exists ($source_files{$value})) 8561 { 8562 $source_files{$value} = $TRUE; 8563 $num_source_files++; 8564 } 8565 } 8566 8567 if ($field =~ /PC Address/) 8568 { 8569 my $segment; 8570 my $offset; 8571#------------------------------------------------------------------------------ 8572# The format of the address is assumed to be the following 2:0x000070a8 8573# Note that the regex is pretty wide. This is from the original code and 8574# could be made more specific: 8575# if ($value =~ /\s*(\S+):(\S+)/) 8576#------------------------------------------------------------------------------ 8577# if ($value =~ /\s*(\S+):(\S+)/) 8578 if ($value =~ /\s*(\d+):0x([0-9a-zA-Z]+)/) 8579 { 8580 $segment = $1; 8581 $offset = $2; 8582#------------------------------------------------------------------------------ 8583# Convert to a base 10 number 8584#------------------------------------------------------------------------------ 8585 $address_decimal = bigint::hex ($offset); # decimal 8586#------------------------------------------------------------------------------ 8587# Construct the address field. Note that we use the hex address here. 8588# For example @2:0x0003f280 8589#------------------------------------------------------------------------------ 8590 $full_address_field = $segment.":0x".$offset; 8591 8592 $function_info[$i]{"addressobj"} = $address_decimal; 8593 $function_info[$i]{"addressobjtext"} = $full_address_field; 8594 $addressobjtextm{$full_address_field} = $i; # $RI 8595 } 8596 if (not exists ($function_address_and_index{$routine}{$value})) 8597 { 8598 $function_address_and_index{$routine}{$value} = $i; 8599 8600 $msg = "function_address_and_index{$routine}{$value} = "; 8601 $msg .= $function_address_and_index{$routine}{$value}; 8602 gp_message ("debugXL", $subr_name, $msg); 8603 } 8604 else 8605 { 8606 $msg = "function_info: $FSUMMARY_FILE: function $routine"; 8607 $msg .= " already has a PC Address"; 8608 gp_message ("debugXL", $subr_name, $msg); 8609 } 8610 8611 $g_total_function_count++; 8612 } 8613 } 8614 close (FSUMMARY_FILE); 8615 8616#------------------------------------------------------------------------------ 8617# For every function in the function overview, set up an html structure with 8618# the various hyperlinks. 8619#------------------------------------------------------------------------------ 8620 gp_message ("debugXL", $subr_name, "augment function_info with alt_name"); 8621 my $target_function; 8622 my $html_line; 8623 my $ftag; 8624 my $routine_length; 8625 my %html_source_functions = (); 8626 for my $i (keys @function_info) 8627 { 8628 $target_function = $function_info[$i]{"routine"}; 8629 8630 gp_message ("debugXL", $subr_name, "i = $i target_function = $target_function"); 8631 8632 my $href_link; 8633## $href_link = "<a href=\'file." . $i . ".src.new.html#"; 8634 $href_link = "<a href=\'file." . $i . "."; 8635 $href_link .= $g_html_base_file_name{"source"}; 8636 $href_link .= ".html#"; 8637 $href_link .= $function_info[$i]{"tag_id"}; 8638 $href_link .= "\'>source</a>"; 8639 $function_info[$i]{"href_source"} = $href_link; 8640 8641 $href_link = "<a href=\'file." . $i . "."; 8642 $href_link .= $g_html_base_file_name{"disassembly"}; 8643 $href_link .= ".html#"; 8644 $href_link .= $function_info[$i]{"tag_id"}; 8645 $href_link .= "\'>disassembly</a>"; 8646 $function_info[$i]{"href_disassembly"} = $href_link; 8647 8648 $href_link = "<a href=\'"; 8649 $href_link .= $g_html_base_file_name{"caller_callee"}; 8650 $href_link .= ".html#"; 8651 $href_link .= $function_info[$i]{"tag_id"}; 8652 $href_link .= "\'>caller-callee</a>"; 8653 $function_info[$i]{"href_caller_callee"} = $href_link; 8654 8655 gp_message ("debug", $subr_name, "g_function_occurrences{$target_function} = $g_function_occurrences{$target_function}"); 8656 8657 if ($g_function_occurrences{$target_function} > 1) 8658 { 8659#------------------------------------------------------------------------------ 8660# In case a function occurs more than one time in the function overview, we 8661# add the load object and address offset info to make it unique. 8662# 8663# This forces us to update some entries in function_info too. 8664#------------------------------------------------------------------------------ 8665 my $loadobj = $function_info[$i]{"Load Object"}; 8666 my $address_field = $function_info[$i]{"addressobjtext"}; 8667 my $address_offset; 8668 8669#------------------------------------------------------------------------------ 8670# The address field has the following format: @<n>:<address_offset> 8671# We only care about the address offset. 8672#------------------------------------------------------------------------------ 8673 if ($address_field =~ /$get_hex_address_regex/) 8674 { 8675 $address_offset = $2; 8676 } 8677 else 8678 { 8679 my $msg = "failed to extract the address offset from $address_field - use the full field"; 8680 gp_message ("warning", $subr_name, $msg); 8681 $address_offset = $address_field; 8682 } 8683 my $exe = get_basename ($loadobj); 8684 my $extra_field = " (<" . $exe . " $address_offset" .">)"; 8685### $target_function .= $extra_field; 8686 $function_info[$i]{"alt_name"} = $target_function . $extra_field; 8687 gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"}); 8688 8689#------------------------------------------------------------------------------ 8690# Store the length of the function name and get the tag id. 8691#------------------------------------------------------------------------------ 8692 $function_info[$i]{"function length"} = length ($target_function . $extra_field); 8693 $function_info[$i]{"tag_id"} = create_function_tag ($i); 8694 8695 gp_message ("debugXL", $subr_name, "updated function_info[$i]{'routine'} = $function_info[$i]{'routine'}"); 8696 gp_message ("debugXL", $subr_name, "updated function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}"); 8697 gp_message ("debugXL", $subr_name, "updated function_info[$i]{'function length'} = $function_info[$i]{'function length'}"); 8698 gp_message ("debugXL", $subr_name, "updated function_info[$i]{'tag_id'} = $function_info[$i]{'tag_id'}"); 8699 } 8700 } 8701 gp_message ("debug", $subr_name, "augment function_info with alt_name completed"); 8702 8703#------------------------------------------------------------------------------ 8704# Compute the maximum function name length. 8705# 8706# The maximum length is stored in %function_view_structure. 8707#------------------------------------------------------------------------------ 8708 my $max_function_length = 0; 8709 for my $i (0 .. $#function_info) 8710 { 8711 $max_function_length = List::Util::max ($max_function_length, $function_info[$i]{"function length"}); 8712 8713 gp_message ("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"}); 8714 } 8715 8716#------------------------------------------------------------------------------ 8717# Define the name of the table and take the length into account, since it may 8718# be longer than the function name(s). 8719#------------------------------------------------------------------------------ 8720 $function_view_structure{"table name"} = "Function name"; 8721 8722 $max_function_length = max ($max_function_length, length ($function_view_structure{"table name"})); 8723 8724 $function_view_structure{"max function length"} = $max_function_length; 8725 8726#------------------------------------------------------------------------------ 8727# Core loop that generates an HTML line for each function. This line is 8728# stored in function_info. 8729#------------------------------------------------------------------------------ 8730 my $top_of_table = $FALSE; 8731 for my $i (keys @function_info) 8732 { 8733 my $new_target_function; 8734 8735 if (defined ($function_info[$i]{"alt_name"})) 8736 { 8737 $target_function = $function_info[$i]{"alt_name"}; 8738 gp_message ("debugXL", $subr_name, "retrieved function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}"); 8739 } 8740 else 8741 { 8742 my $msg = "function_info[$i]{\"alt_name\"} is not defined"; 8743 gp_message ("assertion", $subr_name, $msg); 8744 } 8745 8746 my $function_length = $function_info[$i]{"function length"}; 8747 my $number_of_blanks = $function_view_structure{"max function length"} - $function_length; 8748 8749 my $spaces = " "; 8750 for my $i (1 .. $number_of_blanks) 8751 { 8752 $spaces .= " "; 8753 } 8754 if ($target_function eq "<Total>") 8755#------------------------------------------------------------------------------ 8756# <Total> is a pseudo function and there is no source, or disassembly for it. 8757# We could add a link to the caller-callee part, but this is currently not 8758# done. 8759#------------------------------------------------------------------------------ 8760 { 8761 $top_of_table = $TRUE; 8762 $html_line = " <b><Total></b>"; 8763 } 8764 else 8765 { 8766#------------------------------------------------------------------------------ 8767# Add the * symbol as a marker in case the same function occurs multiple times. 8768# Otherwise insert a space. 8769#------------------------------------------------------------------------------ 8770 my $base_function_name = $function_info[$i]{"routine"}; 8771 if (exists ($g_function_occurrences{$base_function_name})) 8772 { 8773 if ($g_function_occurrences{$base_function_name} > 1) 8774 { 8775 $new_target_function = "*" . $target_function; 8776 } 8777 else 8778 { 8779 $new_target_function = " " . $target_function; 8780 } 8781 } 8782 else 8783 { 8784 my $msg = "g_function_occurrences{$base_function_name} does not exist"; 8785 gp_message ("assertion", $subr_name, $msg); 8786 } 8787 8788#------------------------------------------------------------------------------ 8789# Create the block with the function name, in boldface, plus the links to the 8790# source, disassembly and caller-callee views. 8791#------------------------------------------------------------------------------ 8792 8793#------------------------------------------------------------------------------ 8794# We need to replace the "<" symbol in the code by "<". 8795#------------------------------------------------------------------------------ 8796 $new_target_function =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 8797 8798 $html_line = "<b>$new_target_function</b>" . $spaces; 8799 $html_line .= $function_info[$i]{"href_source"} . " "; 8800 $html_line .= $function_info[$i]{"href_disassembly"} . " "; 8801 $html_line .= $function_info[$i]{"href_caller_callee"}; 8802 } 8803 8804 $msg = "target_function = $target_function html_line = $html_line"; 8805 gp_message ("debugM", $subr_name, $msg); 8806 $html_source_functions{$target_function} = $html_line; 8807 8808#------------------------------------------------------------------------------ 8809# TBD: In the future we want to re-use this block elsewhere. 8810#------------------------------------------------------------------------------ 8811 $function_info[$i]{"html function block"} = $html_line; 8812 } 8813 8814 for my $i (keys %html_source_functions) 8815 { 8816 $msg = "html_source_functions{$i} = $html_source_functions{$i}"; 8817 gp_message ("debugM", $subr_name, $msg); 8818 } 8819 for my $i (keys @function_info) 8820 { 8821 $msg = "function_info[$i]{\"html function block\"} = "; 8822 $msg .= $function_info[$i]{"html function block"}; 8823 gp_message ("debugM", $subr_name, $msg); 8824 } 8825 8826#------------------------------------------------------------------------------ 8827# Print the key data structure %function_info. This is a nested hash. 8828#------------------------------------------------------------------------------ 8829 for my $i (0 .. $#function_info) 8830 { 8831 for my $role (sort keys %{ $function_info[$i] }) 8832 { 8833 $msg = "on return: function_info[$i]{$role} = "; 8834 $msg .= $function_info[$i]{$role}; 8835 gp_message ("debugM", $subr_name, $msg); 8836 } 8837 } 8838#------------------------------------------------------------------------------ 8839# Print the data structure %function_address_and_index. This is a nested hash. 8840#------------------------------------------------------------------------------ 8841 for my $F (keys %function_address_and_index) 8842 { 8843 for my $fields (sort keys %{ $function_address_and_index{$F} }) 8844 { 8845 $msg = "on return: function_address_and_index{$F}{$fields} = "; 8846 $msg .= $function_address_and_index{$F}{$fields}; 8847 gp_message ("debugM", $subr_name, $msg); 8848 } 8849 } 8850#------------------------------------------------------------------------------ 8851# Print the data structure %functions_index. This is a hash with an arrray. 8852#------------------------------------------------------------------------------ 8853 for my $F (keys %functions_index) 8854 { 8855 gp_message ("debug", $subr_name, "on return: functions_index{$F} = @{ $functions_index{$F} }"); 8856# alt code for my $i (0 .. $#{ $functions_index{$F} } ) 8857# alt code { 8858# alt code gp_message ("debug", $subr_name, "on return: \$functions_index{$F} = $functions_index{$F}[$i]"); 8859# alt code } 8860 } 8861 8862#------------------------------------------------------------------------------ 8863# Print the data structure %function_view_structure. This is a hash. 8864#------------------------------------------------------------------------------ 8865 for my $F (keys %function_view_structure) 8866 { 8867 gp_message ("debug", $subr_name, "on return: function_view_structure{$F} = $function_view_structure{$F}"); 8868 } 8869 8870#------------------------------------------------------------------------------ 8871# Print the data structure %g_function_occurrences and use this structure to 8872# gather statistics about the functions. 8873# 8874# TBD: add this info to the experiment data overview. 8875#------------------------------------------------------------------------------ 8876 $number_of_unique_functions = 0; 8877 $number_of_non_unique_functions = 0; 8878 for my $F (keys %g_function_occurrences) 8879 { 8880 gp_message ("debug", $subr_name, "on return: g_function_occurrences{$F} = $g_function_occurrences{$F}"); 8881 if ($g_function_occurrences{$F} == 1) 8882 { 8883 $number_of_unique_functions++; 8884 } 8885 else 8886 { 8887 $number_of_non_unique_functions++; 8888 } 8889 } 8890 8891 for my $i (keys %g_map_function_to_index) 8892 { 8893 my $n = scalar (@{ $g_map_function_to_index{$i} }); 8894 gp_message ("debug", $subr_name, "on return: g_map_function_to_index [$n] : $i => @{ $g_map_function_to_index{$i} }"); 8895 } 8896 8897#------------------------------------------------------------------------------ 8898# TBD: Include this info on the page with experiment data. Include names 8899# with multiple occurrences. 8900#------------------------------------------------------------------------------ 8901 $msg = "Number of source files : " . 8902 $num_source_files; 8903 gp_message ("debug", $subr_name, $msg); 8904 $msg = "Total number of functions : " . 8905 $g_total_function_count; 8906 gp_message ("debug", $subr_name, $msg); 8907 $msg = "Number of functions with a unique name : " . 8908 $number_of_unique_functions; 8909 gp_message ("debug", $subr_name, $msg); 8910 $msg = "Number of functions with more than one occurrence : " . 8911 $number_of_non_unique_functions; 8912 gp_message ("debug", $subr_name, $msg); 8913 my $multi_occurrences = $g_total_function_count - 8914 $number_of_unique_functions; 8915 $msg = "Total number of multiple occurences of the same function name : " . 8916 $multi_occurrences; 8917 gp_message ("debug", $subr_name, $msg); 8918 8919 return (\@function_info, \%function_address_and_index, \%addressobjtextm, 8920 \%LINUX_vDSO, \%function_view_structure); 8921 8922} #-- End of subroutine get_function_info 8923#------------------------------------------------------------------------------ 8924# TBD 8925#------------------------------------------------------------------------------ 8926sub get_hdr_info 8927{ 8928 my $subr_name = get_my_name (); 8929 8930 my ($outputdir, $file) = @_; 8931 8932 state $first_call = $TRUE; 8933 8934 my $ASORTFILE; 8935 my @HDR; 8936 my $HDR; 8937 my $metric; 8938 my $line; 8939 my $ignore_directory; 8940 my $ignore_suffix; 8941 my $number_of_header_lines; 8942 8943#------------------------------------------------------------------------------ 8944# Add a "/" to simplify the construction of path names in the remainder. 8945#------------------------------------------------------------------------------ 8946 $outputdir = append_forward_slash ($outputdir); 8947 8948# Could get more header info from 8949# <metric>[e.bit_fcount].sort.func file - etc. 8950 8951 gp_message ("debug", $subr_name, "input file->$file<-"); 8952#----------------------------------------------- 8953 if ($file eq $outputdir."calls.sort.func") 8954 { 8955 $ASORTFILE=$outputdir."calls"; 8956 $metric = "calls" 8957 } 8958 elsif ($file eq $outputdir."calltree.sort.func") 8959 { 8960 $ASORTFILE=$outputdir."calltree"; 8961 $metric = "calltree" 8962 } 8963 elsif ($file eq $outputdir."functions.sort.func") 8964 { 8965 $ASORTFILE=$outputdir."functions.func"; 8966 $metric = "functions"; 8967 } 8968 else 8969 { 8970 $ASORTFILE = $file; 8971# $metric = basename ($file,".sort.func"); 8972 ($metric, $ignore_directory, $ignore_suffix) = fileparse ($file, ".sort.func"); 8973 gp_message ("debug", $subr_name, "ignore_directory = $ignore_directory ignore_suffix = $ignore_suffix"); 8974 } 8975 8976 gp_message ("debug", $subr_name, "file = $file metric = $metric"); 8977 8978 open (ASORTFILE,"<", $ASORTFILE) 8979 or die ("$subr_name - unable to open file $ASORTFILE for reading: '$!'"); 8980 gp_message ("debug", $subr_name, "opened file $ASORTFILE for reading"); 8981 8982 $number_of_header_lines = 0; 8983 while (<ASORTFILE>) 8984 { 8985 $line =$_; 8986 chomp ($line); 8987 8988 if ($line =~ /^Current/) 8989 { 8990 next; 8991 } 8992 if ($line =~ /^Functions/) 8993 { 8994 next; 8995 } 8996 if ($line =~ /^Callers/) 8997 { 8998 next; 8999 } 9000 if ($line =~ /^\s*$/) 9001 { 9002 next; 9003 } 9004 if (!($line =~ /^\s*\d/)) 9005 { 9006 $HDR[$number_of_header_lines] = $line; 9007 $number_of_header_lines++; 9008 next; 9009 } 9010 last; 9011 } 9012 close (ASORTFILE); 9013#------------------------------------------------------------------------------ 9014# Ruud - Fixed a bug. The output should not be appended, but overwritten. 9015# open (HI,">>$OUTPUTDIR"."hdrinfo"); 9016#------------------------------------------------------------------------------ 9017 my $outfile = $outputdir."hdrinfo"; 9018 9019 if ($first_call) 9020 { 9021 $first_call = $FALSE; 9022 open (HI ,">", $outfile) 9023 or die ("$subr_name - unable to open file $outfile for writing: '$!'"); 9024 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 9025 } 9026 else 9027 { 9028 open (HI ,">>", $outfile) 9029 or die ("$subr_name - unable to open file $outfile in append mode: '$!'"); 9030 gp_message ("debug", $subr_name, "opened file $outfile in append mode"); 9031 } 9032 9033 print HI "\#$metric hdrlines=$number_of_header_lines\n"; 9034 my $len = 0; 9035 for $HDR (@HDR) 9036 { 9037 print HI "$HDR\n"; 9038 gp_message ("debugXL", $subr_name, "HDR = $HDR\n"); 9039 } 9040 close (HI); 9041 if ($first_call) 9042 { 9043 gp_message ("debug", $subr_name, "wrote file $outfile"); 9044 } 9045 else 9046 { 9047 gp_message ("debug", $subr_name, "updated file $outfile"); 9048 } 9049#----------------------------------------------- 9050 9051} #-- End of subroutine get_hdr_info 9052 9053#------------------------------------------------------------------------------ 9054# Get the home directory and the location(s) of the configuration file on the 9055# current system. 9056#------------------------------------------------------------------------------ 9057sub get_home_dir_and_rc_path 9058{ 9059 my $subr_name = get_my_name (); 9060 9061 my ($rc_file_name) = @_; 9062 9063 my @rc_file_paths; 9064 my $target_cmd; 9065 my $home_dir; 9066 my $error_code; 9067 9068 $target_cmd = $g_mapped_cmds{"printenv"} . " HOME"; 9069 9070 ($error_code, $home_dir) = execute_system_cmd ($target_cmd); 9071 9072 if ($error_code != 0) 9073 { 9074 my $msg = "cannot find a setting for HOME - please set this"; 9075 gp_message ("assertion", $subr_name, $msg); 9076 } 9077 else 9078 9079#------------------------------------------------------------------------------ 9080# The home directory is known and we can define the locations for the 9081# configuration file. 9082#------------------------------------------------------------------------------ 9083 { 9084 @rc_file_paths = (".", "$home_dir"); 9085 } 9086 9087 gp_message ("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths"); 9088 9089 return ($home_dir, \@rc_file_paths); 9090 9091} #-- End of subroutine get_home_dir_and_rc_path 9092 9093#------------------------------------------------------------------------------ 9094# This subroutine generates a list with the hot functions. 9095#------------------------------------------------------------------------------ 9096sub get_hot_functions 9097{ 9098 my $subr_name = get_my_name (); 9099 9100 my ($exp_dir_list_ref, $summary_metrics, $input_string) = @_; 9101 9102 my @exp_dir_list = @{ $exp_dir_list_ref }; 9103 9104 my $cmd_output; 9105 my $error_code; 9106 my $expr_name; 9107 my $first_metric; 9108 my $gp_display_text_cmd; 9109 my $ignore_value; 9110 9111 my @sort_fields = (); 9112 9113 $expr_name = join (" ", @exp_dir_list); 9114 9115 gp_message ("debug", $subr_name, "expr_name = $expr_name"); 9116 9117 my $outputdir = append_forward_slash ($input_string); 9118 9119 my $script_file = $outputdir."gp-fsummary.script"; 9120 my $outfile = $outputdir."gp-fsummary.out"; 9121 my $result_file = $outputdir."gp-fsummary.stderr"; 9122 my $gp_error_file = $outputdir.$g_gp_error_logfile; 9123 9124 @sort_fields = split (":", $summary_metrics); 9125 9126#------------------------------------------------------------------------------ 9127# This is extremely unlikely to happen, but if so, it is a fatal error. 9128#------------------------------------------------------------------------------ 9129 my $number_of_elements = scalar (@sort_fields); 9130 9131 gp_message ("debug", $subr_name, "number of fields in summary_metrics = $number_of_elements"); 9132 9133 if ($number_of_elements == 0) 9134 { 9135 my $msg = "there are $number_of_elements in the metrics list"; 9136 gp_message ("assertion", $subr_name, $msg); 9137 } 9138 9139#------------------------------------------------------------------------------ 9140# Get the summary of the hot functions 9141#------------------------------------------------------------------------------ 9142 open (SCRIPT, ">", $script_file) 9143 or die ("$subr_name - unable to open script file $script_file for writing: '$!'"); 9144 gp_message ("debug", $subr_name, "opened script file $script_file for writing"); 9145 9146#------------------------------------------------------------------------------ 9147# TBD: Check what this is about: 9148# Attributed User CPU Time=a.user : for calltree - see P37 in manual 9149#------------------------------------------------------------------------------ 9150 print SCRIPT "# limit 0\n"; 9151 print SCRIPT "limit 0\n"; 9152 print SCRIPT "# metrics $summary_metrics\n"; 9153 print SCRIPT "metrics $summary_metrics\n"; 9154 print SCRIPT "# thread_select all\n"; 9155 print SCRIPT "thread_select all\n"; 9156 9157#------------------------------------------------------------------------------ 9158# Use first out of summary metrics as first (it doesn't matter which one) 9159# $first_metric = (split /:/,$summary_metrics)[0]; 9160#------------------------------------------------------------------------------ 9161 9162 $first_metric = $sort_fields[0]; 9163 9164 print SCRIPT "# outfile $outfile\n"; 9165 print SCRIPT "outfile $outfile\n"; 9166 print SCRIPT "# sort $first_metric\n"; 9167 print SCRIPT "sort $first_metric\n"; 9168 print SCRIPT "# fsummary\n"; 9169 print SCRIPT "fsummary\n"; 9170 9171 close SCRIPT; 9172 9173 my $gp_functions_cmd = "$GP_DISPLAY_TEXT -viewmode machine -compare off -script $script_file $expr_name"; 9174 9175 gp_message ("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the list of functions"); 9176 9177 $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file"; 9178 9179 ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 9180 9181 if ($error_code != 0) 9182 { 9183 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 9184 $error_code, 9185 $gp_error_file); 9186 gp_message ("abort", $subr_name, "execution terminated"); 9187 my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd"; 9188 gp_message ("abort", $subr_name, $msg); 9189 } 9190 9191 return ($outfile,\@sort_fields); 9192 9193} #-- End of subroutine get_hot_functions 9194 9195#------------------------------------------------------------------------------ 9196# For a given function name, return the index into "function_info". This 9197# index gives access to all the meta data for the input function. 9198#------------------------------------------------------------------------------ 9199sub get_index_function_info 9200{ 9201 my $subr_name = get_my_name (); 9202 9203 my ($routine_ref, $hex_address_ref, $function_info_ref) = @_; 9204 9205 my $routine = ${ $routine_ref }; 9206 my $hex_address = ${ $hex_address_ref }; 9207 my @function_info = @{ $function_info_ref }; 9208 9209 my $alt_name = $routine; 9210 my $current_address = $hex_address; 9211 my $found_a_match; 9212 my $index_into_function_info; 9213 my $msg; 9214 my $target_tag; 9215 9216#------------------------------------------------------------------------------ 9217# Check if this function has multiple occurrences. 9218#------------------------------------------------------------------------------ 9219 $msg = "check for multiple occurrences"; 9220 gp_message ("debugM", $subr_name, $msg); 9221 $msg = "target routine name = " . $routine; 9222 gp_message ("debugM", $subr_name, $msg); 9223 9224 if (not exists ($g_multi_count_function{$routine})) 9225 { 9226#------------------------------------------------------------------------------ 9227# There is only a single occurrence and it is straightforward to get the tag. 9228#-------------------------------------------------------------------------- 9229## push (@final_function_names, $routine); 9230## KANWEG for my $key (sort keys %g_map_function_to_index) 9231## KANWEG { 9232## KANWEG $msg = "g_map_function_to_index{". $key . "} = " . $g_map_function_to_index{$key}; 9233## KANWEG gp_message ("debugXL", $subr_name, $msg); 9234## KANWEG } 9235 if (exists ($g_map_function_to_index{$routine})) 9236 { 9237 $index_into_function_info = $g_map_function_to_index{$routine}[0]; 9238 } 9239 else 9240 { 9241 my $msg = "no entry for $routine in g_map_function_to_index"; 9242 gp_message ("assertion", $subr_name, $msg); 9243 } 9244 } 9245 else 9246 { 9247#------------------------------------------------------------------------------ 9248# The function name has more than one occurrence and we need to find the one 9249# that matches with the address. 9250#------------------------------------------------------------------------------ 9251 $found_a_match = $FALSE; 9252 gp_message ("debug", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}"); 9253 for my $ref (keys @{ $g_map_function_to_index{$routine} }) 9254 { 9255 my $ref_index = $g_map_function_to_index{$routine}[$ref]; 9256 my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; 9257 9258 gp_message ("debug", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index"); 9259 gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset"); 9260 9261#------------------------------------------------------------------------------ 9262# TBD: Do this substitution when storing "addressobjtext" in function_info. 9263#------------------------------------------------------------------------------ 9264 $addr_offset =~ s/^@\d+://; 9265 gp_message ("debug", $subr_name, "$routine: addr_offset = $addr_offset"); 9266 if ($addr_offset eq $current_address) 9267 { 9268 $found_a_match = $TRUE; 9269 $index_into_function_info = $ref_index; 9270 last; 9271 } 9272 } 9273 9274#------------------------------------------------------------------------------ 9275# If there is no match, something has gone really wrong and we bail out. 9276#------------------------------------------------------------------------------ 9277 if (not $found_a_match) 9278 { 9279 my $msg = "cannot find the mapping in function_info for function $routine"; 9280 gp_message ("assertion", $subr_name, $msg); 9281 } 9282 } 9283 9284 return (\$index_into_function_info); 9285 9286} #-- End of subroutine get_index_function_info 9287 9288#------------------------------------------------------------------------------ 9289# Get the setting for LANG, or assign a default if it is not set. 9290#------------------------------------------------------------------------------ 9291sub get_LANG_setting 9292{ 9293 my $subr_name = get_my_name (); 9294 9295 my $error_code; 9296 my $lang_setting; 9297 my $target_cmd; 9298 my $command_string; 9299 my $LANG; 9300 9301 $target_cmd = $g_mapped_cmds{"printenv"}; 9302#------------------------------------------------------------------------------ 9303# Use the printenv command to get the settings for LANG. 9304#------------------------------------------------------------------------------ 9305 if ($target_cmd eq "road to nowhere") 9306 { 9307 $error_code = 1; 9308 } 9309 else 9310 { 9311 $command_string = $target_cmd . " LANG"; 9312 ($error_code, $lang_setting) = execute_system_cmd ($command_string); 9313 } 9314 9315 if ($error_code == 0) 9316 { 9317 chomp ($lang_setting); 9318 $LANG = $lang_setting; 9319 } 9320 else 9321 { 9322 $LANG = $g_default_setting_lang; 9323 my $msg = "cannot find a setting for LANG - use a default setting"; 9324 gp_message ("warning", $subr_name, $msg); 9325 } 9326 9327 return ($LANG); 9328 9329} #-- End of subroutine get_LANG_setting 9330 9331#------------------------------------------------------------------------------ 9332# This subroutine gathers the basic information about the metrics. 9333#------------------------------------------------------------------------------ 9334sub get_metrics_data 9335{ 9336 my $subr_name = get_my_name (); 9337 9338 my ($exp_dir_list_ref, $outputdir, $outfile1, $outfile2, $error_file) = @_; 9339 9340 my @exp_dir_list = @{ $exp_dir_list_ref }; 9341 9342 my $cmd_options; 9343 my $cmd_output; 9344 my $error_code; 9345 my $expr_name; 9346 my $metrics_cmd; 9347 my $metrics_output; 9348 my $target_cmd; 9349 9350 $expr_name = join (" ", @exp_dir_list); 9351 9352 gp_message ("debug", $subr_name, "expr_name = $expr_name"); 9353 9354#------------------------------------------------------------------------------ 9355# Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is 9356# to get all the output in files $outfile1 and $outfile2. These are then 9357# parsed. 9358#------------------------------------------------------------------------------ 9359 $cmd_options = " -viewmode machine -compare off -thread_select all"; 9360 $cmd_options .= " -outfile $outfile2"; 9361 $cmd_options .= " -fsingle '<Total>' -metric_list $expr_name"; 9362 9363 $metrics_cmd = "$GP_DISPLAY_TEXT $cmd_options 1> $outfile1 2> $error_file"; 9364 9365 gp_message ("debug", $subr_name, "command used to gather the information:"); 9366 gp_message ("debug", $subr_name, $metrics_cmd); 9367 9368 ($error_code, $metrics_output) = execute_system_cmd ($metrics_cmd); 9369 9370#------------------------------------------------------------------------------ 9371# Error handling. Any error that occurred is fatal and execution 9372# should be aborted by the caller. 9373#------------------------------------------------------------------------------ 9374 if ($error_code == 0) 9375 { 9376 gp_message ("debug", $subr_name, "metrics data in files $outfile1 and $outfile2"); 9377 } 9378 else 9379 { 9380 $target_cmd = $g_mapped_cmds{"cat"} . " $error_file"; 9381 9382 ($error_code, $cmd_output) = execute_system_cmd ($target_cmd); 9383 9384 chomp ($cmd_output); 9385 9386 gp_message ("error", $subr_name, "contents of file $error_file:"); 9387 gp_message ("error", $subr_name, $cmd_output); 9388 } 9389 9390 return ($error_code); 9391 9392} #-- End of subroutine get_metrics_data 9393 9394#------------------------------------------------------------------------------ 9395# Wrapper that returns the last part of the subroutine name. The assumption is 9396# that the last part of the input name is of the form "aa::bb" or just "bb". 9397#------------------------------------------------------------------------------ 9398sub get_my_name 9399{ 9400 my $called_by = (caller (1))[3]; 9401 my @parts = split ("::", $called_by); 9402 return ($parts[$#parts]); 9403 9404## my ($the_full_name_ref) = @_; 9405 9406## my $the_full_name = ${ $the_full_name_ref }; 9407## my $last_part; 9408 9409#------------------------------------------------------------------------------ 9410# If the regex below fails, use the full name." 9411#------------------------------------------------------------------------------ 9412## $last_part = $the_full_name; 9413 9414#------------------------------------------------------------------------------ 9415# Capture the last part if there are multiple parts separated by "::". 9416#------------------------------------------------------------------------------ 9417## if ($the_full_name =~ /.*::(.+)$/) 9418## { 9419## if (defined ($1)) 9420## { 9421## $last_part = $1; 9422## } 9423## } 9424 9425## return (\$last_part); 9426 9427} #-- End of subroutine get_my_name 9428 9429#------------------------------------------------------------------------------ 9430# Determine the characteristics of the current system 9431#------------------------------------------------------------------------------ 9432sub get_system_config_info 9433{ 9434#------------------------------------------------------------------------------ 9435# The output from the "uname" command is used for this. Although not all of 9436# these are currently used, we store all fields in separate variables. 9437#------------------------------------------------------------------------------ 9438# 9439#------------------------------------------------------------------------------ 9440# The options supported on uname from GNU coreutils 8.22: 9441#------------------------------------------------------------------------------ 9442# -a, --all print all information, in the following order, 9443# except omit -p and -i if unknown: 9444# -s, --kernel-name print the kernel name 9445# -n, --nodename print the network node hostname 9446# -r, --kernel-release print the kernel release 9447# -v, --kernel-version print the kernel version 9448# -m, --machine print the machine hardware name 9449# -p, --processor print the processor type or "unknown" 9450# -i, --hardware-platform print the hardware platform or "unknown" 9451# -o, --operating-system print the operating system 9452#------------------------------------------------------------------------------ 9453# Sample output: 9454# 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 9455#------------------------------------------------------------------------------ 9456 my $subr_name = get_my_name (); 9457 9458 my $error_code; 9459 my $hostname_current; 9460 my $ignore_output; 9461 my $msg; 9462 my $target_cmd; 9463#------------------------------------------------------------------------------ 9464# Test once if the command succeeds. This avoids we need to check every 9465# specific # command below. 9466#------------------------------------------------------------------------------ 9467 $target_cmd = $g_mapped_cmds{uname}; 9468 ($error_code, $ignore_output) = execute_system_cmd ($target_cmd); 9469 9470 if ($error_code != 0) 9471#------------------------------------------------------------------------------ 9472# This is unlikely to happen, but you never know. 9473#------------------------------------------------------------------------------ 9474 { 9475 gp_message ("abort", $subr_name, "failure to execute the uname command"); 9476 } 9477 9478 my $kernel_name = qx ($target_cmd -s); chomp ($kernel_name); 9479 my $nodename = qx ($target_cmd -n); chomp ($nodename); 9480 my $kernel_release = qx ($target_cmd -r); chomp ($kernel_release); 9481 my $kernel_version = qx ($target_cmd -v); chomp ($kernel_version); 9482 my $machine = qx ($target_cmd -m); chomp ($machine); 9483 my $processor = qx ($target_cmd -p); chomp ($processor); 9484 my $hardware_platform = qx ($target_cmd -i); chomp ($hardware_platform); 9485 my $operating_system = qx ($target_cmd -o); chomp ($operating_system); 9486 9487 $local_system_config{"kernel_name"} = $kernel_name; 9488 $local_system_config{"nodename"} = $nodename; 9489 $local_system_config{"kernel_release"} = $kernel_release; 9490 $local_system_config{"kernel_version"} = $kernel_version; 9491 $local_system_config{"machine"} = $machine; 9492 $local_system_config{"processor"} = $processor; 9493 $local_system_config{"hardware_platform"} = $hardware_platform; 9494 $local_system_config{"operating_system"} = $operating_system; 9495 9496 gp_message ("debug", $subr_name, "the output from the $target_cmd command is split into the following variables:"); 9497 gp_message ("debug", $subr_name, "kernel_name = $kernel_name"); 9498 gp_message ("debug", $subr_name, "nodename = $nodename"); 9499 gp_message ("debug", $subr_name, "kernel_release = $kernel_release"); 9500 gp_message ("debug", $subr_name, "kernel_version = $kernel_version"); 9501 gp_message ("debug", $subr_name, "machine = $machine"); 9502 gp_message ("debug", $subr_name, "processor = $processor"); 9503 gp_message ("debug", $subr_name, "hardware_platform = $hardware_platform"); 9504 gp_message ("debug", $subr_name, "operating_system = $operating_system"); 9505 9506#------------------------------------------------------------------------------ 9507# Check if the system we are running on is supported. 9508#------------------------------------------------------------------------------ 9509 my $is_supported = ${ check_support_for_processor (\$machine) }; 9510 9511 if (not $is_supported) 9512 { 9513 $msg = "the $machine instruction set architecture is not supported"; 9514 gp_message ("error", $subr_name, $msg); 9515 gp_message ("diag", $subr_name, "Error: " . $msg); 9516 9517 $msg = "temporarily ignored for development purposes"; 9518 gp_message ("error", $subr_name, $msg); 9519 9520 $g_total_error_count++; 9521 exit (0); 9522 } 9523#------------------------------------------------------------------------------ 9524# The current hostname is used to compare against the hostname(s) found in the 9525# experiment directories. 9526#------------------------------------------------------------------------------ 9527 $target_cmd = $g_mapped_cmds{hostname}; 9528 $hostname_current = qx ($target_cmd); chomp ($hostname_current); 9529 $error_code = ${^CHILD_ERROR_NATIVE}; 9530 9531 if ($error_code == 0) 9532 { 9533 $local_system_config{"hostname_current"} = $hostname_current; 9534 } 9535 else 9536#------------------------------------------------------------------------------ 9537# This is unlikely to happen, but you never know. 9538#------------------------------------------------------------------------------ 9539 { 9540 gp_message ("abort", $subr_name, "failure to execute the hostname command"); 9541 } 9542 for my $key (sort keys %local_system_config) 9543 { 9544 gp_message ("debug", $subr_name, "local_system_config{$key} = $local_system_config{$key}"); 9545 } 9546 9547 return (0); 9548 9549} #-- End of subroutine get_system_config_info 9550 9551#------------------------------------------------------------------------------ 9552# This subroutine prints a message. Several types of messages are supported. 9553# In case the type is "abort", or "error", execution is terminated. 9554# 9555# Note that "debug", "warning", and "error" mode, the name of the calling 9556# subroutine is truncated to 30 characters. In case the name is longer, 9557# a warning message # is issued so you know this has happened. 9558# 9559# Note that we use lcfirst () and ucfirst () to enforce whether the first 9560# character is printed in lower or uppercase. It is nothing else than a 9561# convenience, but creates more consistency across messages. 9562#------------------------------------------------------------------------------ 9563sub gp_message 9564{ 9565 my $subr_name = get_my_name (); 9566 9567 my ($action, $caller_name, $comment_line) = @_; 9568 9569#------------------------------------------------------------------------------ 9570# The debugXL identifier is special. It is accepted, but otherwise ignored. 9571# This allows to (temporarily) disable debug print statements, but keep them 9572# around. 9573#------------------------------------------------------------------------------ 9574 my %supported_identifiers = ( 9575 "verbose" => "[Verbose]", 9576 "debug" => "[Debug]", 9577 "error" => "[Error]", 9578 "warning" => "[Warning]", 9579 "abort" => "[Abort]", 9580 "assertion" => "[Assertion error]", 9581 "diag" => "", 9582 ); 9583 9584 my $debug_size; 9585 my $identifier; 9586 my $fixed_size_name; 9587 my $ignore_value; 9588 my $string_limit = 30; 9589 my $strlen = length ($caller_name); 9590 my $trigger_debug = $FALSE; 9591 my $truncated_name; 9592 my $msg; 9593 9594 if ($action =~ /debug\s*(.+)/) 9595 { 9596 if (defined ($1)) 9597 { 9598 my $orig_value = $1; 9599 $debug_size = lc ($1); 9600 9601 if ($debug_size =~ /^s$|^m$|^l$|^xl$/) 9602 { 9603 if ($g_debug_size{$debug_size}) 9604 { 9605#------------------------------------------------------------------------------ 9606# All we need to know is whether a debug action is requested and whether the 9607# size has been enabled. By setting $action to "debug", the code below is 9608# simplified. Note that only using $trigger_debug below is actually sufficient. 9609#------------------------------------------------------------------------------ 9610 $trigger_debug = $TRUE; 9611 } 9612 } 9613 else 9614 { 9615 die "$subr_name: debug size $orig_value is not supported"; 9616 } 9617 $action = "debug"; 9618 } 9619 } 9620 elsif ($action eq "debug") 9621 { 9622 $trigger_debug = $TRUE; 9623 } 9624 9625#------------------------------------------------------------------------------ 9626# Catch any non-supported identifier. 9627#------------------------------------------------------------------------------ 9628 if (defined ($supported_identifiers{$action})) 9629 { 9630 $identifier = $supported_identifiers{$action}; 9631 } 9632 else 9633 { 9634 die ("$subr_name - input error: $action is not supported"); 9635 } 9636 if (($action eq "debug") and (not $g_debug)) 9637 { 9638 $trigger_debug = $FALSE; 9639 } 9640 9641#------------------------------------------------------------------------------ 9642# Unconditionally buffer all warning messages. These are available through the 9643# index.html page and cannot be disabled. 9644# 9645# If the quiet mode has been enabled, warnings are not printed though. 9646#------------------------------------------------------------------------------ 9647 if ($action eq "warning") 9648 { 9649#------------------------------------------------------------------------------ 9650# Remove any leading <br>, capitalize the first letter, and put the <br> back 9651# before storing the message in the buffer. 9652#------------------------------------------------------------------------------ 9653 if ($comment_line =~ /^$g_html_new_line/) 9654 { 9655 $msg = $comment_line; 9656 $msg =~ s/$g_html_new_line//; 9657 $comment_line = $g_html_new_line . ucfirst ($msg); 9658 9659 push (@g_warning_msgs, $comment_line); 9660 } 9661 else 9662 { 9663 push (@g_warning_msgs, ucfirst ($comment_line)); 9664 } 9665 } 9666 9667#------------------------------------------------------------------------------ 9668# Unconditionally buffer all errror messages. These will be printed prior to 9669# terminate execution. 9670#------------------------------------------------------------------------------ 9671 if ($action eq "error") 9672#------------------------------------------------------------------------------ 9673# Remove any leading <br>, capitalize the first letter, and put the <br> back. 9674#------------------------------------------------------------------------------ 9675 { 9676 if ($comment_line =~ /^$g_html_new_line/) 9677 { 9678 $msg = $comment_line; 9679 $msg =~ s/$g_html_new_line//; 9680 $comment_line = $g_html_new_line . ucfirst ($msg); 9681 9682 push (@g_error_msgs, $comment_line); 9683 } 9684 else 9685 { 9686 push (@g_error_msgs, ucfirst ($comment_line)); 9687 } 9688 } 9689 9690#------------------------------------------------------------------------------ 9691# Quick return in several cases. Note that "debug", "verbose", "warning", and 9692# "diag" messages are suppressed in quiet mode, but "error", "abort" and 9693# "assertion" always pass. 9694#------------------------------------------------------------------------------ 9695 if (( 9696 ($action eq "verbose") and (not $g_verbose)) 9697 or (($action eq "debug") and (not $trigger_debug)) 9698 or (($action eq "verbose") and ($g_quiet)) 9699 or (($action eq "debug") and ($g_quiet)) 9700 or (($action eq "warning") and ($g_quiet)) 9701 or (($action eq "diag") and ($g_quiet))) 9702 { 9703 return (0); 9704 } 9705 9706#------------------------------------------------------------------------------ 9707# In diag mode, just print the input line and nothing else. 9708#------------------------------------------------------------------------------ 9709 if (( 9710 $action eq "debug") 9711 or ($action eq "abort") 9712 or ($action eq "assertion")) 9713## or ($action eq "error")) 9714 { 9715#------------------------------------------------------------------------------ 9716# Construct the string to be printed. Include an identifier and the name of 9717# the function. 9718#------------------------------------------------------------------------------ 9719 if ($strlen > $string_limit) 9720 { 9721 $truncated_name = substr ($caller_name, 0, $string_limit); 9722 $fixed_size_name = sprintf ("%-"."$string_limit"."s", $truncated_name); 9723 print "Warning in $subr_name - the name of the caller is: " . 9724 $caller_name . "\n"; 9725 print "Warning in $subr_name - the string length is $strlen and " . 9726 "exceeds $string_limit\n"; 9727 } 9728 else 9729 { 9730 $fixed_size_name = sprintf ("%-"."$string_limit"."s", $caller_name); 9731 } 9732 9733## if (($action eq "error") or ($action eq "abort")) 9734 if ($action eq "abort") 9735#------------------------------------------------------------------------------ 9736# Enforce that the message starts with a lowercase symbol. Since these are 9737# user errors, the name of the routine is not shown. The same for "abort". 9738# If you want to display the routine name too, use an assertion. 9739#------------------------------------------------------------------------------ 9740 { 9741 my $error_identifier = $supported_identifiers{"error"}; 9742 if (@g_error_msgs) 9743 { 9744 $ignore_value = print_errors_buffer (\$error_identifier); 9745 } 9746 printf ("%-9s %s", $identifier, ucfirst ($comment_line)); 9747 printf (" - %s\n", "execution is terminated"); 9748 } 9749 elsif ($action eq "assertion") 9750#------------------------------------------------------------------------------ 9751# Enforce that the message starts with a lowercase symbol. 9752#------------------------------------------------------------------------------ 9753 { 9754#------------------------------------------------------------------------------ 9755# The lines are too long, but breaking the argument list gives this warning: 9756# printf (...) interpreted as function 9757#------------------------------------------------------------------------------ 9758 printf ("%-17s %-30s", $identifier, $fixed_size_name); 9759 printf (" - %s\n", $comment_line); 9760 } 9761 elsif (($action eq "debug") and ($trigger_debug)) 9762#------------------------------------------------------------------------------ 9763# Debug messages are printed "as is". Avoids issues when searching for them ;-) 9764#------------------------------------------------------------------------------ 9765 { 9766 printf ("%-9s %-30s", $identifier, $fixed_size_name); 9767 printf (" - %s\n", $comment_line); 9768 } 9769 else 9770#------------------------------------------------------------------------------ 9771# Enforce that the message starts with a lowercase symbol. 9772#------------------------------------------------------------------------------ 9773 { 9774 printf ("%-9s %-30s", $identifier, $fixed_size_name); 9775 printf (" - %s\n", $comment_line); 9776 } 9777 } 9778 elsif ($action eq "verbose") 9779#------------------------------------------------------------------------------ 9780# The first character in the verbose message is capatilized. 9781#------------------------------------------------------------------------------ 9782 { 9783 printf ("%s\n", ucfirst ($comment_line)); 9784 } 9785 elsif ($action eq "diag") 9786#------------------------------------------------------------------------------ 9787# The diag messages are meant to be diagnostics. Only the comment line is 9788# printed. 9789#------------------------------------------------------------------------------ 9790 { 9791 printf ("%s\n", $comment_line); 9792 return (0); 9793 } 9794 9795#------------------------------------------------------------------------------ 9796# Terminate execution in case the identifier is "abort". 9797#------------------------------------------------------------------------------ 9798 if (($action eq "abort") or ($action eq "assertion")) 9799 { 9800## print "ABORT temporarily disabled for testing purposes\n"; 9801 exit (-1); 9802 } 9803 else 9804 { 9805 return (0); 9806 } 9807 9808} #-- End of subroutine gp_message 9809 9810#------------------------------------------------------------------------------ 9811# Create an HTML page with the warnings. If there are no warnings, include 9812# line to this extent. The alternative is to supporess the entire page, but 9813# that breaks the consistency in the output. 9814#------------------------------------------------------------------------------ 9815sub html_create_warnings_page 9816{ 9817 my $subr_name = get_my_name (); 9818 9819 my ($outputdir_ref) = @_; 9820 9821 my $outputdir = ${ $outputdir_ref }; 9822 9823 my $file_title; 9824 my $html_acknowledgement; 9825 my $html_end; 9826 my $html_header; 9827 my $html_home_left; 9828 my $html_home_right; 9829 my $html_title_header; 9830 my $msg_no_warnings = "There are no warning messages issued."; 9831 my $page_title; 9832 my $position_text; 9833 my $size_text; 9834 9835 my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html"; 9836 9837 gp_message ("debug", $subr_name, "outfile = $outfile"); 9838 9839 open (WARNINGS_OUT, ">", $outfile) 9840 or die ("unable to open $outfile for writing - '$!'"); 9841 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 9842 9843 gp_message ("debug", $subr_name, "building warning file $outfile"); 9844 9845#------------------------------------------------------------------------------ 9846# Generate some of the structures used in the HTML output. 9847#------------------------------------------------------------------------------ 9848 $file_title = "Warning messages"; 9849 $html_header = ${ create_html_header (\$file_title) }; 9850 $html_home_right = ${ generate_home_link ("right") }; 9851 9852 $page_title = "Warning Messages"; 9853 $size_text = "h2"; 9854 $position_text = "center"; 9855 $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 9856 9857#------------------------------------------------------------------------------ 9858# Get the acknowledgement, return to main link, and final html statements. 9859#------------------------------------------------------------------------------ 9860 $html_home_left = ${ generate_home_link ("left") }; 9861 $html_acknowledgement = ${ create_html_credits () }; 9862 $html_end = ${ terminate_html_document () }; 9863 9864#------------------------------------------------------------------------------ 9865# Generate the HTML file. 9866#------------------------------------------------------------------------------ 9867 print WARNINGS_OUT $html_header; 9868 print WARNINGS_OUT $html_home_right; 9869 print WARNINGS_OUT $html_title_header; 9870 9871 if ($g_total_warning_count > 0) 9872 { 9873 print WARNINGS_OUT "<pre>\n"; 9874 print WARNINGS_OUT "$_\n" for @g_warning_msgs; 9875 print WARNINGS_OUT "</pre>\n"; 9876 } 9877 else 9878 { 9879 print WARNINGS_OUT $msg_no_warnings; 9880 } 9881 9882 print WARNINGS_OUT $html_home_left; 9883 print WARNINGS_OUT "<br>\n"; 9884 print WARNINGS_OUT $html_acknowledgement; 9885 print WARNINGS_OUT $html_end; 9886 9887 close (WARNINGS_OUT); 9888 9889 return (0); 9890 9891} #-- End of subroutine html_create_warnings_page 9892 9893#------------------------------------------------------------------------------ 9894# Generate the HTML with the experiment summary. 9895#------------------------------------------------------------------------------ 9896sub html_generate_exp_summary 9897{ 9898 my $subr_name = get_my_name (); 9899 9900 my ($outputdir_ref, $experiment_data_ref) = @_; 9901 9902 my $outputdir = ${ $outputdir_ref }; 9903 my @experiment_data = @{ $experiment_data_ref }; 9904 my $file_title; 9905 my $outfile; 9906 my $page_title; 9907 my $size_text; 9908 my $position_text; 9909 my $html_header; 9910 my $html_home; 9911 my $html_title_header; 9912 my $html_acknowledgement; 9913 my $html_end; 9914 my @html_exp_table_data = (); 9915 my $html_exp_table_data_ref; 9916 my @table_execution_stats = (); 9917 my $table_execution_stats_ref; 9918 9919 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 9920 $outputdir = append_forward_slash ($outputdir); 9921 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 9922 9923 $file_title = "Experiment information"; 9924 $page_title = "Experiment Information"; 9925 $size_text = "h2"; 9926 $position_text = "center"; 9927 $html_header = ${ create_html_header (\$file_title) }; 9928 $html_home = ${ generate_home_link ("right") }; 9929 9930 $html_title_header = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 9931 9932 $outfile = $outputdir . $g_html_base_file_name{"experiment_info"} . ".html"; 9933 open (EXP_INFO, ">", $outfile) 9934 or die ("unable to open $outfile for writing - '$!'"); 9935 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 9936 9937 print EXP_INFO $html_header; 9938 print EXP_INFO $html_home; 9939 print EXP_INFO $html_title_header; 9940 9941 ($html_exp_table_data_ref, $table_execution_stats_ref) = html_generate_table_data ($experiment_data_ref); 9942 9943 @html_exp_table_data = @{ $html_exp_table_data_ref }; 9944 @table_execution_stats = @{ $table_execution_stats_ref }; 9945 9946 print EXP_INFO "$_" for @html_exp_table_data; 9947; 9948## print EXP_INFO "<pre>\n"; 9949## print EXP_INFO "$_\n" for @html_caller_callee; 9950## print EXP_INFO "</pre>\n"; 9951 9952#------------------------------------------------------------------------------ 9953# Get the acknowledgement, return to main link, and final html statements. 9954#------------------------------------------------------------------------------ 9955 $html_home = ${ generate_home_link ("left") }; 9956 $html_acknowledgement = ${ create_html_credits () }; 9957 $html_end = ${ terminate_html_document () }; 9958 9959 print EXP_INFO $html_home; 9960 print EXP_INFO "<br>\n"; 9961 print EXP_INFO $html_acknowledgement; 9962 print EXP_INFO $html_end; 9963 9964 close (EXP_INFO); 9965 9966 return (\@table_execution_stats); 9967 9968} #-- End of subroutine html_generate_exp_summary 9969 9970#------------------------------------------------------------------------------ 9971# Generate the index.html file. 9972#------------------------------------------------------------------------------ 9973sub html_generate_index 9974{ 9975 my $subr_name = get_my_name (); 9976 9977 my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref, 9978 $number_of_metrics_ref, $function_info_ref, $function_address_info_ref, 9979 $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref, 9980 $metric_description_reversed_ref, $table_execution_stats_ref) = @_; 9981 9982 my $outputdir = ${ $outputdir_ref }; 9983 my $html_first_metric_file = ${ $html_first_metric_file_ref }; 9984 my $summary_metrics = ${ $summary_metrics_ref }; 9985 my $number_of_metrics = ${ $number_of_metrics_ref }; 9986 my @function_info = @{ $function_info_ref }; 9987 my %function_address_info = %{ $function_address_info_ref }; 9988 my @sort_fields = @{ $sort_fields_ref }; 9989 my @exp_dir_list = @{ $exp_dir_list_ref }; 9990 my %addressobjtextm = %{ $addressobjtextm_ref }; 9991 my %metric_description_reversed = %{ $metric_description_reversed_ref }; 9992 my @table_execution_stats = @{ $table_execution_stats_ref }; 9993 9994 my @file_contents = (); 9995 9996 my $acknowledgement; 9997 my @abs_path_exp_dirs = (); 9998 my $input_experiments; 9999 my $target_function; 10000 my $html_line; 10001 my $ftag; 10002 my $max_length = 0; 10003 my %html_source_functions = (); 10004 my $html_header; 10005 my @experiment_directories = (); 10006 my $html_acknowledgement; 10007 my $html_file_title; 10008 my $html_output_file; 10009 my $html_function_view; 10010 my $html_caller_callee_view; 10011 my $html_experiment_info; 10012 my $html_warnings_page; 10013 my $href_link; 10014 my $file_title; 10015 my $html_gprofng; 10016 my $html_end; 10017 my $max_length_metrics; 10018 my $page_title; 10019 my $size_text; 10020 my $position_text; 10021 10022 my $ln; 10023 my $base; 10024 my $base_index_page; 10025 my $infile; 10026 my $outfile; 10027 my $rec; 10028 my $skip; 10029 my $callsize; 10030 my $dest; 10031 my $final_string; 10032 my @headers; 10033 my $header; 10034 my $sort_index; 10035 my $pc_address; 10036 my $anchor; 10037 my $directory_name; 10038 my $f2; 10039 my $f3; 10040 my $file; 10041 my $sline; 10042 my $src; 10043 my $srcfile_name; 10044 my $tmp1; 10045 my $tmp2; 10046 my $fullsize; 10047 my $regf2; 10048 my $trimsize; 10049 my $EIL; 10050 my $EEIL; 10051 my $AOBJ; 10052 my $RI; 10053 my $HDR; 10054 my $CALLER_CALLEE; 10055 my $NAME; 10056 my $SRC; 10057 my $TRIMMED; 10058 10059#------------------------------------------------------------------------------ 10060# Add a forward slash to make it easier when creating file names. 10061#------------------------------------------------------------------------------ 10062 $outputdir = append_forward_slash ($outputdir); 10063 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 10064 10065 my $LANG = $g_locale_settings{"LANG"}; 10066 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 10067 10068 $input_experiments = join (", ", @exp_dir_list); 10069 10070 for my $i (0 .. $#exp_dir_list) 10071 { 10072 my $dir = get_basename ($exp_dir_list[$i]); 10073 push @abs_path_exp_dirs, $dir; 10074 } 10075 $input_experiments = join (", ", @abs_path_exp_dirs); 10076 10077 gp_message ("debug", $subr_name, "input_experiments = $input_experiments"); 10078 10079#------------------------------------------------------------------------------ 10080# TBD: Pass in the values for $expr_name and $cmd 10081#------------------------------------------------------------------------------ 10082 $html_file_title = "Main index page"; 10083 10084 @experiment_directories = split (",", $input_experiments); 10085 $html_acknowledgement = ${ create_html_credits () }; 10086 10087 $html_end = ${ terminate_html_document () }; 10088 10089 $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html"; 10090 10091 open (INDEX, ">", $html_output_file) 10092 or die ("$subr_name - unable to open file $html_output_file for writing - '$!'"); 10093 gp_message ("debug", $subr_name, "opened file $html_output_file for writing"); 10094 10095 $page_title = "GPROFNG Performance Analysis"; 10096 $size_text = "h1"; 10097 $position_text = "center"; 10098 $html_gprofng = ${ generate_a_header (\$page_title, \$size_text, \$position_text) }; 10099 10100 $html_header = ${ create_html_header (\$html_file_title) }; 10101 10102 print INDEX $html_header; 10103 print INDEX $html_gprofng; 10104 print INDEX "$_" for @g_html_experiment_stats; 10105 print INDEX "$_" for @table_execution_stats; 10106 10107 $html_experiment_info = "<a href=\'"; 10108 $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html"; 10109 $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n"; 10110 10111 $html_warnings_page = "<a href=\'"; 10112 $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html"; 10113 $html_warnings_page .= "\'><h3>Warnings (" . $g_total_warning_count; 10114 $html_warnings_page .= ")</h3></a>\n"; 10115 10116 $html_function_view = "<a href=\'"; 10117 $html_function_view .= $html_first_metric_file; 10118 $html_function_view .= "\'><h3>Function View</h3></a>\n"; 10119 10120 $html_caller_callee_view = "<a href=\'"; 10121 $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html"; 10122 $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n"; 10123 10124 print INDEX "<br>\n"; 10125## print INDEX "<b>\n"; 10126 print INDEX $html_experiment_info; 10127 print INDEX $html_warnings_page; 10128## print INDEX "<br>\n"; 10129## print INDEX "<br>\n"; 10130 print INDEX $html_function_view; 10131## print INDEX "<br>\n"; 10132## print INDEX "<br>\n"; 10133 print INDEX $html_caller_callee_view; 10134## print INDEX "</b>\n"; 10135## print INDEX "<br>\n"; 10136## print INDEX "<br>\n"; 10137 10138 print INDEX $html_acknowledgement; 10139 print INDEX $html_end; 10140 10141 close (INDEX); 10142 10143 gp_message ("debug", $subr_name, "closed file $html_output_file"); 10144 10145 return (0); 10146 10147} #-- End of subroutine html_generate_index 10148 10149#------------------------------------------------------------------------------ 10150# Generate the entries for the tables with the experiment info. 10151#------------------------------------------------------------------------------ 10152sub html_generate_table_data 10153{ 10154 my $subr_name = get_my_name (); 10155 10156 my ($experiment_data_ref) = @_; 10157 10158 my @experiment_data = (); 10159 my @html_exp_table_data = (); 10160 my $html_line; 10161## my $html_header_line; 10162 my $entry_name; 10163 my $key; 10164 my $size_text; 10165 my $position_text; 10166 my $title_table_1; 10167 my $title_table_2; 10168 my $title_table_3; 10169 my $title_table_summary; 10170 my $html_table_title; 10171 10172 my @experiment_table_1_def = (); 10173 my @experiment_table_2_def = (); 10174 my @experiment_table_3_def = (); 10175 my @exp_table_summary_def = (); 10176 my @experiment_table_1 = (); 10177 my @experiment_table_2 = (); 10178 my @experiment_table_3 = (); 10179 my @exp_table_summary = (); 10180 my @exp_table_selection = (); 10181 10182 @experiment_data = @{ $experiment_data_ref }; 10183 10184 for my $i (sort keys @experiment_data) 10185 { 10186 for my $fields (sort keys %{ $experiment_data[$i] }) 10187 { 10188 gp_message ("debugXL", $subr_name, "$i => experiment_data[$i]{$fields} = $experiment_data[$i]{$fields}"); 10189 } 10190 } 10191 10192 $title_table_1 = "Target System Configuration"; 10193 $title_table_2 = "Experiment Statistics"; 10194 $title_table_3 = "Run Time Statistics"; 10195 $title_table_summary = "Main Statistics"; 10196 10197 $size_text = "h3"; 10198 $position_text = "left"; 10199 10200 push @experiment_table_1_def, { name => "Experiment name" , key => "exp_name_short"}; 10201 push @experiment_table_1_def, { name => "Hostname" , key => "hostname"}; 10202 push @experiment_table_1_def, { name => "Operating system", key => "OS"}; 10203 push @experiment_table_1_def, { name => "Architecture", key => "architecture"}; 10204 push @experiment_table_1_def, { name => "Page size", key => "page_size"}; 10205 10206 push @experiment_table_2_def, { name => "Target command" , key => "target_cmd"}; 10207 push @experiment_table_2_def, { name => "Date command executed" , key => "start_date"}; 10208 push @experiment_table_2_def, { name => "Data collection duration", key => "data_collection_duration"}; 10209 push @experiment_table_2_def, { name => "End time of the experiment", key => "end_experiment"}; 10210 10211 push @experiment_table_3_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; 10212## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"}; 10213 push @experiment_table_3_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; 10214## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"}; 10215 push @experiment_table_3_def, { name => "Sleep time (seconds)", key => "sleep_time"}; 10216## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"}; 10217 10218 push @exp_table_summary_def, { name => "Experiment name" , key => "exp_name_short"}; 10219 push @exp_table_summary_def, { name => "Hostname" , key => "hostname"}; 10220 push @exp_table_summary_def, { name => "User CPU time (seconds)", key => "user_cpu_time"}; 10221 push @exp_table_summary_def, { name => "System CPU time (seconds)", key => "system_cpu_time"}; 10222 push @exp_table_summary_def, { name => "Sleep time (seconds)", key => "sleep_time"}; 10223 10224 $html_table_title = ${ generate_a_header (\$title_table_1, \$size_text, \$position_text) }; 10225 10226 push (@html_exp_table_data, $html_table_title); 10227 10228 @experiment_table_1 = @{ create_table (\@experiment_data, \@experiment_table_1_def) }; 10229 10230 push (@html_exp_table_data, @experiment_table_1); 10231 10232 $html_table_title = ${ generate_a_header (\$title_table_2, \$size_text, \$position_text) }; 10233 10234 push (@html_exp_table_data, $html_table_title); 10235 10236 @experiment_table_2 = @{ create_table (\@experiment_data, \@experiment_table_2_def) }; 10237 10238 push (@html_exp_table_data, @experiment_table_2); 10239 10240 $html_table_title = ${ generate_a_header (\$title_table_3, \$size_text, \$position_text) }; 10241 10242 push (@html_exp_table_data, $html_table_title); 10243 10244 @experiment_table_3 = @{ create_table (\@experiment_data, \@experiment_table_3_def) }; 10245 10246 push (@html_exp_table_data, @experiment_table_3); 10247 10248 $html_table_title = ${ generate_a_header (\$title_table_summary, \$size_text, \$position_text) }; 10249 10250 push (@exp_table_summary, $html_table_title); 10251 10252 @exp_table_selection = @{ create_table (\@experiment_data, \@exp_table_summary_def) }; 10253 10254 push (@exp_table_summary, @exp_table_selection); 10255 10256 return (\@html_exp_table_data, \@exp_table_summary); 10257 10258} #-- End of subroutine html_generate_table_data 10259 10260#------------------------------------------------------------------------------ 10261# Generate the HTML text to print in case a file is empty. 10262#------------------------------------------------------------------------------ 10263sub html_text_empty_file 10264{ 10265 my $subr_name = get_my_name (); 10266 10267 my ($comment_ref, $error_file_ref) = @_; 10268 10269 my $comment; 10270 my $error_file; 10271 my $error_message; 10272 my $file_title; 10273 my $html_end; 10274 my $html_header; 10275 my $html_home; 10276 10277 my @html_empty_file = (); 10278 10279 $comment = ${ $comment_ref }; 10280 $error_file = ${ $error_file_ref }; 10281 10282 $file_title = "File is empty"; 10283 $html_header = ${ create_html_header (\$file_title) }; 10284 $html_end = ${ terminate_html_document () }; 10285 $html_home = ${ generate_home_link ("left") }; 10286 10287 push (@html_empty_file, $html_header); 10288 10289 $error_message = "<b>" . $comment . "</b>"; 10290 $error_message = set_background_color_string ($error_message, $g_html_color_scheme{"error_message"}); 10291 push (@html_empty_file, $error_message); 10292 10293 if (not is_file_empty ($error_file)) 10294 { 10295 $error_message = "<p><em>Check file $error_file for more information</em></p>"; 10296 } 10297 push (@html_empty_file, $error_message); 10298 push (@html_empty_file, $html_home); 10299 push (@html_empty_file, "<br>"); 10300 push (@html_empty_file, $g_html_credits_line); 10301 push (@html_empty_file, $html_end); 10302 10303 return (\@html_empty_file); 10304 10305} #-- End of subroutine html_text_empty_file 10306 10307#------------------------------------------------------------------------------ 10308# This subroutine checks if a file is empty and returns $TRUE or $FALSE. 10309#------------------------------------------------------------------------------ 10310sub is_file_empty 10311{ 10312 my $subr_name = get_my_name (); 10313 10314 my ($filename) = @_; 10315 10316 my $is_empty; 10317 my $file_stat; 10318 my $msg; 10319 my $size; 10320 10321 chomp ($filename); 10322 10323 if (not -e $filename) 10324 { 10325#------------------------------------------------------------------------------ 10326# The return value is used in the caller. This is why we return the empty 10327# string in case the file does not exist. 10328#------------------------------------------------------------------------------ 10329 $msg = "filename = $filename not found"; 10330 gp_message ("debug", $subr_name, $msg); 10331 $is_empty = $TRUE; 10332 } 10333 else 10334 { 10335 $file_stat = stat ($filename); 10336 $size = $file_stat->size; 10337 $is_empty = ($size == 0) ? $TRUE : $FALSE; 10338 } 10339 10340 $msg = "filename = $filename size = $size is_empty = $is_empty"; 10341 gp_message ("debug", $subr_name, $msg); 10342 10343 return ($is_empty); 10344 10345} #-- End of subroutine is_file_empty 10346 10347#------------------------------------------------------------------------------ 10348# Check if a file is executable and return $TRUE or $FALSE. 10349#------------------------------------------------------------------------------ 10350sub is_file_executable 10351{ 10352 my $subr_name = get_my_name (); 10353 10354 my ($filename) = @_; 10355 10356 my $file_permissions; 10357 my $index_offset; 10358 my $is_executable; 10359 my $mode; 10360 my $number_of_bytes; 10361 my @permission_settings = (); 10362 my %permission_values = (); 10363 10364 chomp ($filename); 10365 10366 gp_message ("debug", $subr_name, "check if filename = $filename is executable"); 10367 10368 if (not -e $filename) 10369 { 10370#------------------------------------------------------------------------------ 10371# The return value is used in the caller. This is why we return the empty 10372# string in case the file does not exist. 10373#------------------------------------------------------------------------------ 10374 gp_message ("debug", $subr_name, "filename = $filename not found"); 10375 $is_executable = $FALSE; 10376 } 10377 else 10378 { 10379 $mode = stat ($filename)->mode; 10380 10381 gp_message ("debugXL", $subr_name, "mode = $mode"); 10382#------------------------------------------------------------------------------ 10383# Get username. We currently do not do anything with this though and the 10384# code is commented out. 10385# 10386# my $my_name = getlogin () || getpwuid($<) || "Kilroy"; 10387# gp_message ("debug", $subr_name, "my_name = $my_name"); 10388#------------------------------------------------------------------------------ 10389 10390#------------------------------------------------------------------------------ 10391# Convert file permissions to octal, split the individual numbers and store 10392# the values for the respective users. 10393#------------------------------------------------------------------------------ 10394 $file_permissions = sprintf("%o", $mode & 07777); 10395 10396 @permission_settings = split (//, $file_permissions); 10397 10398 $number_of_bytes = scalar (@permission_settings); 10399 10400 gp_message ("debugXL", $subr_name, "file_permissions = $file_permissions"); 10401 gp_message ("debugXL", $subr_name, "permission_settings = @permission_settings"); 10402 gp_message ("debugXL", $subr_name, "number_of_settings = $number_of_bytes"); 10403 10404 if ($number_of_bytes == 4) 10405 { 10406 $index_offset = 1; 10407 } 10408 elsif ($number_of_bytes == 3) 10409 { 10410 $index_offset = 0; 10411 } 10412 else 10413 { 10414 my $msg = "unexpected number of $number_of_bytes bytes " . 10415 "in permission settings: @permission_settings"; 10416 gp_message ("assertion", $subr_name, $msg); 10417 } 10418 10419 $permission_values{user} = $permission_settings[$index_offset++]; 10420 $permission_values{group} = $permission_settings[$index_offset++]; 10421 $permission_values{other} = $permission_settings[$index_offset]; 10422 10423#------------------------------------------------------------------------------ 10424# The executable bit should be set for user, group and other. If this fails 10425# we mark the file as not executable. Note that this is gprofng specific. 10426#------------------------------------------------------------------------------ 10427 $is_executable = $TRUE; 10428 for my $k (keys %permission_values) 10429 { 10430 my $msg = "permission_values{" . $k . "} = " . 10431 $permission_values{$k}; 10432 gp_message ("debugXL", $subr_name, $msg); 10433 10434 if ($permission_values{$k} % 2 == 0) 10435 { 10436 $is_executable = $FALSE; 10437 last; 10438 } 10439 } 10440 } 10441 10442 gp_message ("debug", $subr_name, "is_executable = $is_executable"); 10443 10444 return ($is_executable); 10445 10446} #-- End of subroutine is_file_executable 10447 10448#------------------------------------------------------------------------------ 10449# Print a message after a failure in $GP_DISPLAY_TEXT. 10450#------------------------------------------------------------------------------ 10451sub msg_display_text_failure 10452{ 10453 my $subr_name = get_my_name (); 10454 10455 my ($gp_display_text_cmd, $error_code, $error_file) = @_; 10456 10457 my $msg; 10458 10459 $msg = "error code = $error_code - failure executing the following command:"; 10460 gp_message ("error", $subr_name, $msg); 10461 10462 gp_message ("error", $subr_name, $gp_display_text_cmd); 10463 10464 $msg = "check file $error_file for more details"; 10465 gp_message ("error", $subr_name, $msg); 10466 10467 return (0); 10468 10469} #-- End of subroutine msg_display_text_failure 10470 10471#------------------------------------------------------------------------------ 10472# TBD. 10473#------------------------------------------------------------------------------ 10474sub name_regex 10475{ 10476 my $subr_name = get_my_name (); 10477 10478 my ($metric_description_ref, $metrics, $field, $file) = @_; 10479 10480 my %metric_description = %{ $metric_description_ref }; 10481 10482 my @splitted_metrics; 10483 my $splitted_metrics; 10484 my $m; 10485 my $mf; 10486 my $nf; 10487 my $re; 10488 my $Xre; 10489 my $noPCfile; 10490 my @reported_metrics; 10491 my $reported_metrics; 10492 my $hdr_regex; 10493 my $hdr_href_regex; 10494 my $hdr_src_regex; 10495 my $new_metrics; 10496 my $pre; 10497 my $post; 10498 my $rat; 10499 my @moo = (); 10500 10501 my $gp_metrics_file; 10502 my $gp_metrics_dir; 10503 my $suffix_not_used; 10504 10505 my $is_calls = $FALSE; 10506 my $is_calltree = $FALSE; 10507 10508 gp_message ("debugXL", $subr_name,"1:metrics->$metrics<- field->$field<- file->$file<-"); 10509 10510#------------------------------------------------------------------------------ 10511# According to https://perldoc.perl.org/File::Basename, both dirname and 10512# basename are not reliable and fileparse () is recommended instead. 10513# 10514# Note that $gp_metrics_dir has a trailing "/". 10515#------------------------------------------------------------------------------ 10516 ($gp_metrics_file, $gp_metrics_dir, $suffix_not_used) = fileparse ($file, ".sort.func-PC"); 10517 10518 gp_message ("debugXL", $subr_name, "gp_metrics_dir = $gp_metrics_dir gp_metrics_file = $gp_metrics_file"); 10519 gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used"); 10520 10521 if ($gp_metrics_file eq "calls") 10522 { 10523 $is_calls = $TRUE; 10524 } 10525 if ($gp_metrics_file eq "calltree") 10526 { 10527 $is_calltree = $TRUE; 10528 } 10529 10530 $gp_metrics_file = "gp-metrics-" . $gp_metrics_file . "-PC"; 10531 $gp_metrics_file = $gp_metrics_dir . $gp_metrics_file; 10532 10533 gp_message ("debugXL", $subr_name, "gp_metrics_file is $gp_metrics_file"); 10534 10535 open (GP_METRICS, "<", $gp_metrics_file) 10536 or die ("$subr_name - unable to open gp_metrics file $gp_metrics_file for reading - '$!'"); 10537 gp_message ("debug", $subr_name, "opened file $gp_metrics_file for reading"); 10538 10539 $new_metrics = $metrics; 10540 10541 while (<GP_METRICS>) 10542 { 10543 $rat = $_; 10544 chomp ($rat); 10545 gp_message ("debugXL", $subr_name, "rat = $rat - new_metrics = $new_metrics"); 10546#------------------------------------------------------------------------------ 10547# Capture the string after "Current metrics:" and if it ends with ":name", 10548# remove it. 10549#------------------------------------------------------------------------------ 10550 if ($rat =~ /^\s*Current metrics:\s*(.*)$/) 10551 { 10552 $new_metrics = $1; 10553 if ($new_metrics =~ /^(.*):name$/) 10554 { 10555 $new_metrics = $1; 10556 } 10557 last; 10558 } 10559 } 10560 close (GP_METRICS); 10561 10562 if ($is_calls or $is_calltree) 10563 { 10564#------------------------------------------------------------------------------ 10565# Remove any inclusive metrics from the list. 10566#------------------------------------------------------------------------------ 10567 while ($new_metrics =~ /(.*)(i\.[^:]+)(.*)$/) 10568 { 10569 $pre = $1; 10570 $post = $3; 10571 gp_message ("debugXL", $subr_name, "1b: new_metrics = $new_metrics pre = $pre post = $post"); 10572 if (substr ($post,0,1) eq ":") 10573 { 10574 $post = substr ($post,1); 10575 } 10576 $new_metrics = $pre.$post; 10577 } 10578 } 10579 10580 $metrics = $new_metrics; 10581 10582 gp_message ("debugXL", $subr_name, "2:metrics->$metrics<- field->$field<- file->$file<-"); 10583 10584#------------------------------------------------------------------------------ 10585# Find the line starting with "address:" and strip this part away. 10586#------------------------------------------------------------------------------ 10587 if ($metrics =~ /^address:(.*)/) 10588 { 10589 $reported_metrics = $1; 10590#------------------------------------------------------------------------------ 10591# Focus on the filename ending with "-PC". When found, strip this part away. 10592#------------------------------------------------------------------------------ 10593 if ($file =~ /^(.*)-PC$/) 10594 { 10595 $noPCfile = $1; 10596 if ($noPCfile =~ /^(.*)functions.sort.func$/) 10597 { 10598 $noPCfile = $1."functions.func"; 10599 } 10600 push (@moo, "$reported_metrics\n"); 10601 } 10602 } 10603 10604#------------------------------------------------------------------------------ 10605# Split the list into an array with the individual metrics. 10606# 10607# TBD: This should be done only once! 10608#------------------------------------------------------------------------------ 10609 @reported_metrics = split (":", $reported_metrics); 10610 for my $i (@reported_metrics) 10611 { 10612 gp_message ("debugXL", $subr_name, "reported_metrics = $i"); 10613 } 10614 10615 $hdr_regex = "^\\s*"; 10616 $hdr_href_regex = "^\\s*"; 10617 $hdr_src_regex = "^(\\s+|<i>\\s+)"; 10618 10619 for my $m (@reported_metrics) 10620 { 10621 10622 my $description = ${ retrieve_metric_description (\$m, \%metric_description) }; 10623 gp_message ("debugXL", $subr_name, "m = $m description = $description"); 10624 if (substr ($m,0,1) eq "e") 10625 { 10626 push (@moo,"$m:$description\n"); 10627 $hdr_regex .= "(Excl\\.\.*)"; 10628 $hdr_href_regex .= "(<a.*>)(Excl\\.)(<\/a>)([^<]+)"; 10629 $hdr_src_regex .= "(Excl\\.\.*)"; 10630 next; 10631 } 10632 if (substr ($m,0,1) eq "i") 10633 { 10634 push (@moo,"$m:$description\n"); 10635 $hdr_regex .= "(Incl\\.\.*)"; 10636 $hdr_href_regex .= "(<a.*>)(Incl\\.)(<\/a>)([^<]+)"; 10637 $hdr_src_regex .= "(Incl\\.\.*)"; 10638 next; 10639 } 10640 if (substr ($m,0,1) eq "a") 10641 { 10642 my $a; 10643 my $am; 10644 $a = $m; 10645 $a =~ s/^a/e/; 10646 $am = ${ retrieve_metric_description (\$a, \%metric_description) }; 10647 $am =~ s/Exclusive/Attributed/; 10648 push (@moo,"$m:$am\n"); 10649 $hdr_regex .= "(Attr\\.\.*)"; 10650 $hdr_href_regex .= "(<a.*>)(Attr\\.)(<\/a>)([^<]+)"; 10651 $hdr_src_regex .= "(Attr\\.\.*)";next; 10652 } 10653 } 10654 10655 $hdr_regex .= "(Name\.*)"; 10656 $hdr_href_regex .= "(Name\.*)"; 10657 10658 @splitted_metrics = split (":","$metrics"); 10659 $nf = scalar (@splitted_metrics); 10660 gp_message ("debug", $subr_name,"number of fields in $metrics -> $nf"); 10661 10662 open (ZMETRICS, ">", "$noPCfile.metrics") 10663 or die ("Not able to open file $noPCfile.metrics for writing - '$!'"); 10664 gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.metrics for writing"); 10665 10666 print ZMETRICS @moo; 10667 close (ZMETRICS); 10668 10669 gp_message ("debug", $subr_name, "wrote file $noPCfile.metrics"); 10670 10671 open (XREGEXP, ">", "$noPCfile.c.regex") 10672 or die ("Not able to open file $noPCfile.c.regex for writing - '$!'"); 10673 gp_message ("debug", $subr_name, "$noPCfile - opened file $noPCfile.c.regex for writing"); 10674 10675 print XREGEXP "\# Number of metric fields\n"; 10676 print XREGEXP "$nf\n"; 10677 print XREGEXP "\# Header regex\n"; 10678 print XREGEXP "$hdr_regex\n"; 10679 print XREGEXP "\# href Header regex\n"; 10680 print XREGEXP "$hdr_href_regex\n"; 10681 print XREGEXP "\# src Header regex\n"; 10682 print XREGEXP "$hdr_src_regex\n"; 10683 10684 $mf = 1; 10685#--------------------------------------------------------------------------- 10686# Find the index of "field" in the metric list, plus one. 10687#--------------------------------------------------------------------------- 10688 if ( ($field eq "functions") or ($field eq "calls") or ($field eq "calltree")) 10689 { 10690 $mf = $nf + 1; 10691 } 10692 else 10693 { 10694 for my $candidate_metric (@splitted_metrics) 10695 { 10696 gp_message ("debugXL", $subr_name, "field = $field candidate_metric = $candidate_metric and mf = $mf"); 10697 if ($candidate_metric eq $field) 10698 { 10699 last; 10700 } 10701 $mf++; 10702 } 10703 } 10704 gp_message ("debugXL", $subr_name, "Final value mf = $mf"); 10705 10706 if ($mf == 1) 10707 { 10708 $re = "^\\s*(\\S+)"; # metric value 10709 } 10710 else 10711 { 10712 $re = "^\\s*\\S+"; 10713 } 10714 $Xre = "^\\s*(\\S+)"; 10715 10716 $m = 2; 10717 while (--$nf) 10718 { 10719 if ($nf) 10720 { 10721 if ($m == $mf) 10722 { 10723 $re .= "\\s+(\\S+)"; # metric value 10724 } 10725 else 10726 { 10727 $re .= "\\s+\\S+"; 10728 } 10729 if ($nf != 1) 10730 { 10731 $Xre .= "\\s+(\\S+)"; 10732 } 10733 $m++; 10734 } 10735 } 10736 10737 if ($field eq "calltree") 10738 { 10739 $re .= "\\s+.*\\+-(.*)"; # name 10740 $Xre .= "\\s+.*\\+-(.*)\$"; # name (Right?) 10741 } 10742 else 10743 { 10744 $re .= "\\s+(.*)"; # name 10745 $Xre .= "\\s+(.*)\$"; # name 10746 } 10747 10748 print XREGEXP "\# Metrics and Name regex\n"; 10749 print XREGEXP "$Xre\n"; 10750 close (XREGEXP); 10751 10752 gp_message ("debug", $subr_name, "wrote file $noPCfile.c.regex"); 10753 gp_message ("debugXL", $subr_name, "on return Xre = $Xre"); 10754 gp_message ("debugXL", $subr_name, "on return re = $re"); 10755 10756 return ($re); 10757 10758} #-- End of subroutine name_regex 10759 10760#------------------------------------------------------------------------------ 10761# TBD 10762#------------------------------------------------------------------------------ 10763sub nosrc 10764{ 10765 my $subr_name = get_my_name (); 10766 10767 my ($input_string) = @_; 10768 10769 my $directory_name = append_forward_slash ($input_string); 10770 my $LANG = $g_locale_settings{"LANG"}; 10771 my $result_file = $directory_name."no_source.html"; 10772 10773 gp_message ("debug", $subr_name, "result_file = $result_file"); 10774 10775 open (NS, ">", $result_file) 10776 or die ("$subr_name: cannot open file $result_file for writing - '$!'"); 10777 10778 print NS "<!doctype html public \"-//w3c//dtd html 3.2//en\">\n<html lang=\"$LANG\">\n<head>\n". 10779 "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" . 10780 "<title>No source</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."><pre>\n"; 10781 print NS "<a name=\"line1\"></a><font color=#C80707>"."No source was found"."</font>\n"; # red font 10782 print NS "</pre>\n<pre>Output generated by $version_info</pre>\n"; 10783 print NS "</body></html>\n"; 10784 10785 close (NS); 10786 10787 return (0); 10788 10789} #-- End of subroutine nosrc 10790 10791#------------------------------------------------------------------------------ 10792# TBD. 10793#------------------------------------------------------------------------------ 10794sub numerically 10795{ 10796 my $f1; 10797 my $f2; 10798 10799 if ($a =~ /^([^\d]*)(\d+)/) 10800 { 10801 $f1 = int ($2); 10802 if ($b=~ /^([^\d]*)(\d+)/) 10803 { 10804 $f2 = int ($2); 10805 $f1 == $f2 ? 0 : ($f1 < $f2 ? -1 : +1); 10806 } 10807 } 10808 else 10809 { 10810 return ($a <=> $b); 10811 } 10812} #-- End of subroutine numerically 10813 10814#------------------------------------------------------------------------------ 10815# Parse the user options. Also perform a basic check. More checks and also 10816# some more specific to the option, plus cross option checks, will be 10817# performed soon after this subroutine has executed. 10818# 10819# Warnings, but also errors, are buffered. In this way we can collect as many 10820# warnings and errors as possible, before bailing out in case of an error. 10821#------------------------------------------------------------------------------ 10822sub parse_and_check_user_options 10823{ 10824 my $subr_name = get_my_name (); 10825 10826 my @exp_dir_list; 10827 10828 my $arg; 10829 my $calltree_value; 10830 my $debug_value; 10831 my $default_metrics_value; 10832 my $func_limit_value; 10833 my $found_exp_dir = $FALSE; 10834 my $ignore_metrics_value; 10835 my $ignore_value; 10836 my $msg; 10837 my $outputdir_value; 10838 my $quiet_value; 10839 my $hp_value; 10840 my $valid; 10841 my $verbose_value; 10842 10843 my $number_of_fields; 10844 10845 my $internal_option_name; 10846 my $option_name; 10847 10848 my $verbose = undef; 10849 my $warning = undef; 10850 10851 my @opt_debug = (); 10852 my @opt_highlight_percentage = (); 10853 my @opt_nowarnings = (); 10854 my @opt_obsoleted_hp = (); 10855 my @opt_output = (); 10856 my @opt_overwrite = (); 10857 my @opt_quiet = (); 10858 my @opt_verbose = (); 10859 my @opt_warnings = (); 10860 10861#------------------------------------------------------------------------------ 10862#------------------------------------------------------------------------------ 10863 my $no_of_warnings; 10864 my $total_warning_msgs = 0; 10865 my $option_value; 10866 my $option_warnings; 10867 my $no_of_warnings_ref; 10868 my $no_of_errors_ref; 10869 10870 my $index_exp; 10871 my $first = $TRUE; 10872 my $trigger = $FALSE; 10873 my $found_non_exp = $FALSE; 10874 my $name_non_exp_dir; 10875 my $no_of_experiments = 0; 10876 10877 my @opt_help = (); 10878 my @opt_version = (); 10879 my $stop_execution = $FALSE; 10880 10881 my $option_value_ref; 10882 my $max_occurrences; 10883#------------------------------------------------------------------------------ 10884# Configure Getopt to: 10885# - Silence warnings, since these are handled by the code. 10886# - Enforce case sensitivity in order to support -o and -O for example. 10887#------------------------------------------------------------------------------ 10888 Getopt::Long::Configure("pass_through", "no_ignore_case"); 10889 10890#------------------------------------------------------------------------------ 10891# Check for the --help and --version options. Print a message and exit. 10892# Note that we support using both options simultaneously on the command line. 10893#------------------------------------------------------------------------------ 10894 GetOptions ( 10895 "help" => \@opt_help, 10896 "version" => \@opt_version 10897 ); 10898 10899 if (@opt_help) 10900 { 10901 $stop_execution = $TRUE; 10902 $ignore_value = print_help_info (); 10903 } 10904 if (@opt_version) 10905 { 10906 $stop_execution = $TRUE; 10907 $ignore_value = print_version_info (); 10908 } 10909 10910 if ($stop_execution) 10911 { 10912 exit (0); 10913 } 10914 10915#------------------------------------------------------------------------------ 10916# First, scan ARGV for the experiment names. If there are no names, or the 10917# list with the names is not contiguous (meaning there is an non-experiment 10918# name in this list), an error message is printed and execution is terminated. 10919# 10920# Upon return from this function, the list with the experiment names is 10921# known and has been removed from ARGV. 10922# 10923# As a result, exp_dir_list is available from there on. 10924# 10925# This makes the subsequent processing of ARGV with GetOptions() easier. 10926#------------------------------------------------------------------------------ 10927 @exp_dir_list = @{ check_the_experiment_list () }; 10928 10929#------------------------------------------------------------------------------ 10930# Configure Getopt to: 10931# - Silence warnings, since these are handled by the code. 10932# - Enforce case sensitivity in order to support -o and -O for example. 10933# - Allow unique abbreviations (also the default). 10934#------------------------------------------------------------------------------ 10935 Getopt::Long::Configure("pass_through", "no_ignore_case", "auto_abbrev"); 10936#------------------------------------------------------------------------------ 10937# Get the remaining command line options. 10938# 10939# Recall: 10940# = => option requires a value 10941# : => option value is optional 10942#------------------------------------------------------------------------------ 10943 10944#------------------------------------------------------------------------------ 10945# All options are considered to be a string. 10946# 10947# We request every option supported to have an optional value. Otherwise, 10948# GetOptions skips an option that does not have a value. 10949# 10950# The logic that parses the options deals with this and checks if an option 10951# that should have a value, actually has one. 10952#------------------------------------------------------------------------------ 10953 GetOptions ( 10954 "verbose|v:s" => \@opt_verbose, 10955 "debug|d:s" => \@opt_debug, 10956 "warnings|w:s" => \@opt_warnings, 10957 "nowarnings:s" => \@opt_nowarnings, 10958 "quiet|q:s" => \@opt_quiet, 10959 "output|o=s" => \@opt_output, 10960 "overwrite|O=s" => \@opt_overwrite, 10961 "highlight-percentage=s" => \@opt_highlight_percentage, 10962 "hp=s" => \@opt_obsoleted_hp 10963 ); 10964 10965#------------------------------------------------------------------------------ 10966#------------------------------------------------------------------------------ 10967# Handle the user input and where needed, generate warnings. In a later stage 10968# we check for (cross option) errors and warnings. 10969#------------------------------------------------------------------------------ 10970#------------------------------------------------------------------------------ 10971 10972#------------------------------------------------------------------------------ 10973# The very first thing to do is to determine if the user has enabled one of the 10974# following options and take action accordingly: 10975# --quiet, --verbose, --debug, --warnings 10976# 10977# We first need to check for quiet mode to be set. If so, all messages need to 10978# be silenced, regardless of the settings for verbose, debug, and warnings. 10979#------------------------------------------------------------------------------ 10980 10981#------------------------------------------------------------------------------ 10982# The quiet option. 10983#------------------------------------------------------------------------------ 10984 if (@opt_quiet) 10985 { 10986 $max_occurrences = 1; 10987 $internal_option_name = "quiet"; 10988 $option_name = "--quiet"; 10989 10990 my ($valid_ref) = extract_option_value (\@opt_quiet, 10991 \$max_occurrences, 10992 \$internal_option_name, 10993 \$option_name); 10994 10995 $valid = ${ $valid_ref }; 10996 10997 if ($valid) 10998 { 10999 $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ? 11000 $TRUE : $FALSE; 11001 } 11002 } 11003 11004#------------------------------------------------------------------------------ 11005# The debug option. 11006#------------------------------------------------------------------------------ 11007 if (@opt_debug) 11008 { 11009 $max_occurrences = 1; 11010 $internal_option_name = "debug"; 11011 $option_name = "-d/--debug"; 11012 11013 my ($valid_ref) = extract_option_value (\@opt_debug, 11014 \$max_occurrences, 11015 \$internal_option_name, 11016 \$option_name); 11017 11018 $valid = ${ $valid_ref }; 11019 11020 if ($valid) 11021#------------------------------------------------------------------------------ 11022# Set the appropriate debug size (e.g. "XL") in a table that is used in the 11023# gp_message() subroutine. 11024#------------------------------------------------------------------------------ 11025 { 11026 $g_debug = $TRUE; 11027 $ignore_value = set_debug_size (); 11028 } 11029 } 11030 11031#------------------------------------------------------------------------------ 11032# The verbose option. 11033#------------------------------------------------------------------------------ 11034 if (@opt_verbose) 11035 { 11036 $max_occurrences = 1; 11037 $internal_option_name = "verbose"; 11038 $option_name = "--verbose"; 11039 11040 my ($valid_ref) = extract_option_value (\@opt_verbose, 11041 \$max_occurrences, 11042 \$internal_option_name, 11043 \$option_name); 11044 $valid = ${ $valid_ref }; 11045 11046 if ($valid) 11047 { 11048 $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ? 11049 $TRUE : $FALSE; 11050 } 11051 } 11052 11053#------------------------------------------------------------------------------ 11054# The nowarnings option. 11055#------------------------------------------------------------------------------ 11056 if (@opt_nowarnings) 11057 { 11058 $max_occurrences = 1; 11059 $internal_option_name = "nowarnings"; 11060 $option_name = "--nowarnings"; 11061 11062 my ($valid_ref) = extract_option_value (\@opt_nowarnings, 11063 \$max_occurrences, 11064 \$internal_option_name, 11065 \$option_name); 11066 11067 $valid = ${ $valid_ref }; 11068 11069 if ($valid) 11070 { 11071 $g_warnings = 11072 $g_user_settings{"nowarnings"}{"current_value"} eq "on" ? 11073 $FALSE : $TRUE; 11074 } 11075 } 11076 11077#------------------------------------------------------------------------------ 11078# The warnings option (deprecated). 11079#------------------------------------------------------------------------------ 11080 if (@opt_warnings) 11081 { 11082 $max_occurrences = 1; 11083 $internal_option_name = "warnings"; 11084 $option_name = "--warnings"; 11085 11086 my ($valid_ref) = extract_option_value (\@opt_warnings, 11087 \$max_occurrences, 11088 \$internal_option_name, 11089 \$option_name); 11090 } 11091 11092#------------------------------------------------------------------------------ 11093# At this point, the debug, verbose, warnings and quiet settings are known. 11094# This subroutine makes the final decision on these settings. For example, if 11095# quiet mode has been specified, the settings for debug, verbose and warnings 11096# are ignored. 11097#------------------------------------------------------------------------------ 11098 $ignore_value = finalize_special_options (); 11099 11100#------------------------------------------------------------------------------ 11101# A this point we know we can start printing messages in case verbose and/or 11102# debug mode have been set. 11103#------------------------------------------------------------------------------ 11104 $msg = "the original command line options: " . join (", ", @CopyOfARGV); 11105 gp_message ("debug", $subr_name, $msg); 11106 11107 $msg = "the command line options after the special options: " . 11108 join (", ", @ARGV); 11109 gp_message ("debug", $subr_name, $msg); 11110 11111 gp_message ("verbose", $subr_name, "Parsing the user options"); 11112 11113#------------------------------------------------------------------------------ 11114# The output option. 11115#------------------------------------------------------------------------------ 11116 if (@opt_output) 11117 { 11118 $max_occurrences = 1; 11119 $internal_option_name = "output"; 11120 $option_name = "-o/--output"; 11121 11122 my ($valid_ref) = extract_option_value (\@opt_output, 11123 \$max_occurrences, 11124 \$internal_option_name, 11125 \$option_name); 11126 } 11127 11128#------------------------------------------------------------------------------ 11129# The overwrite option. 11130#------------------------------------------------------------------------------ 11131 if (@opt_overwrite) 11132 { 11133 $max_occurrences = 1; 11134 $internal_option_name = "overwrite"; 11135 $option_name = "-O/--overwrite"; 11136 11137 my ($valid_ref) = extract_option_value (\@opt_overwrite, 11138 \$max_occurrences, 11139 \$internal_option_name, 11140 \$option_name); 11141 } 11142 11143#------------------------------------------------------------------------------ 11144# The highlight-percentage option. 11145#------------------------------------------------------------------------------ 11146 if (@opt_highlight_percentage) 11147 { 11148 $max_occurrences = 1; 11149 $internal_option_name = "highlight_percentage"; 11150 $option_name = "--highlight-percentage"; 11151 11152 my ($valid_ref) = extract_option_value (\@opt_highlight_percentage, 11153 \$max_occurrences, 11154 \$internal_option_name, 11155 \$option_name); 11156 } 11157 11158#------------------------------------------------------------------------------ 11159# The hp option (deprecated) 11160#------------------------------------------------------------------------------ 11161 if (@opt_obsoleted_hp) 11162 { 11163 $max_occurrences = 1; 11164 $internal_option_name = "hp"; 11165 $option_name = "-hp"; 11166 11167 my ($valid_ref) = extract_option_value (\@opt_obsoleted_hp, 11168 \$max_occurrences, 11169 \$internal_option_name, 11170 \$option_name); 11171 } 11172 11173#------------------------------------------------------------------------------ 11174# By now, all options given on the command line have been processed and the 11175# list with experiment directories is known. 11176# 11177# Process the remainder of ARGV, but other than the option generated by the 11178# driver, ARGV should be empty. 11179#------------------------------------------------------------------------------ 11180 $ignore_value = wrap_up_user_options (); 11181 11182# Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit")) 11183# Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree")) 11184# Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage")) 11185# Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics")) 11186# Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics")) 11187 11188 if (@exp_dir_list) 11189#------------------------------------------------------------------------------ 11190# Print the list of the experiment directories found. 11191# 11192# Note that later we also check for these directories to actually exist 11193# and be valid experiments.. 11194#------------------------------------------------------------------------------ 11195 { 11196 $found_exp_dir = $TRUE; 11197 $msg = "the following experiment directories will be used:"; 11198 gp_message ("debug", $subr_name, $msg); 11199 for my $i (keys @exp_dir_list) 11200 { 11201 my $msg = "exp_dir_list[$i] = $exp_dir_list[$i]"; 11202 gp_message ("debug", $subr_name, $msg); 11203 } 11204 } 11205 else 11206#------------------------------------------------------------------------------ 11207# Print a message if the experiment list is not valid, or empty. There will 11208# also be error messages in the buffer. These will be printed later. 11209#------------------------------------------------------------------------------ 11210 { 11211 $msg = "experiment directory name(s) are either not valid, or missing"; 11212 gp_message ("debug", $subr_name, $msg); 11213 } 11214 11215 return (\$found_exp_dir, \@exp_dir_list); 11216 11217} #-- End of subroutine parse_and_check_user_options 11218 11219#------------------------------------------------------------------------------ 11220# Parse the generated .dis files 11221#------------------------------------------------------------------------------ 11222sub parse_dis_files 11223{ 11224 my $subr_name = get_my_name (); 11225 11226 my ($number_of_metrics_ref, $function_info_ref, 11227 $function_address_and_index_ref, $input_string_ref, 11228 $addressobj_index_ref) = @_; 11229 11230#------------------------------------------------------------------------------ 11231# Note that $function_address_and_index_ref is not used, but we need to pass 11232# in the address into generate_dis_html. 11233#------------------------------------------------------------------------------ 11234 my $number_of_metrics = ${ $number_of_metrics_ref }; 11235 my @function_info = @{ $function_info_ref }; 11236 my $input_string = ${ $input_string_ref }; 11237 my %addressobj_index = %{ $addressobj_index_ref }; 11238 11239#------------------------------------------------------------------------------ 11240# The regex section. 11241#------------------------------------------------------------------------------ 11242 my $dis_filename_id_regex = 'file\.([0-9]+)\.dis'; 11243 11244 my $filename; 11245 my $msg; 11246 my $outputdir = append_forward_slash ($input_string); 11247 11248 my @source_line = (); 11249 my $source_line_ref; 11250 11251 my @metric = (); 11252 my $metric_ref; 11253 11254 my $target_function; 11255 11256 gp_message ("debug", $subr_name, "building disassembly files"); 11257 gp_message ("debug", $subr_name, "outputdir = $outputdir"); 11258 11259 while (glob ($outputdir.'*.dis')) 11260 { 11261 gp_message ("debug", $subr_name, "processing disassembly file: $_"); 11262 11263 my $base_name = get_basename ($_); 11264 11265 if ($base_name =~ /$dis_filename_id_regex/) 11266 { 11267 if (defined ($1)) 11268 { 11269 gp_message ("debug", $subr_name, "processing disassembly file: $base_name $1"); 11270 if (exists ($function_info[$1]{"routine"})) 11271 { 11272 $target_function = $function_info[$1]{"routine"}; 11273 gp_message ("debug", $subr_name, "processing disassembly file: $base_name target_function = $target_function"); 11274 } 11275 if (exists ($g_function_tag_id{$target_function})) 11276 { 11277 gp_message ("debug", $subr_name, "target_function = $target_function ftag = $g_function_tag_id{$target_function}"); 11278 } 11279 else 11280 { 11281 my $msg = "no function tag found for $target_function"; 11282 gp_message ("assertion", $subr_name, $msg); 11283 } 11284 } 11285 else 11286 { 11287 gp_message ("debug", $subr_name, "processing disassembly file: $base_name unknown id"); 11288 } 11289 } 11290 11291 $filename = $_; 11292 gp_message ("verbose", $subr_name, " Processing disassembly file $filename"); 11293 ($source_line_ref, $metric_ref) = generate_dis_html ( 11294 \$target_function, 11295 \$number_of_metrics, 11296 $function_info_ref, 11297 $function_address_and_index_ref, 11298 \$outputdir, 11299 \$filename, 11300 \@source_line, 11301 \@metric, 11302 \%addressobj_index); 11303 11304 @source_line = @{ $source_line_ref }; 11305 11306#------------------------------------------------------------------------------ 11307# TBD. This part needs work. The return variables from generate_dis_html () 11308# are not used, so the code below is meaningless, but awaiting a true fix, 11309# the problem which appears on aarch64 is bypassed. 11310#------------------------------------------------------------------------------ 11311 if (defined ($metric_ref)) 11312 { 11313 @metric = @{ $metric_ref }; 11314 } 11315 else 11316 { 11317 $msg = "metric_ref after generate_dis_html is undefined"; 11318 gp_message ("debug", $subr_name, $msg); 11319 } 11320 } 11321 11322 return (0) 11323 11324} #-- End of subroutine parse_dis_files 11325 11326#------------------------------------------------------------------------------ 11327# Parse the .src.txt files 11328#------------------------------------------------------------------------------ 11329sub parse_source_files 11330{ 11331 my $subr_name = get_my_name (); 11332 11333 my ($number_of_metrics_ref, $function_info_ref, $outputdir_ref) = @_; 11334 11335 my $number_of_metrics = ${ $number_of_metrics_ref }; 11336 my $outputdir = ${ $outputdir_ref }; 11337 my $ignore_value; 11338 11339 my $outputdir_with_slash = append_forward_slash ($outputdir); 11340 11341 gp_message ("verbose", $subr_name, "building source files"); 11342 11343 while (glob ($outputdir_with_slash.'*.src.txt')) 11344 { 11345 gp_message ("verbose", $subr_name, " Processing source file: $_"); 11346 gp_message ("debug", $subr_name, "processing source file: $_"); 11347 11348 my $found_target = process_source ( 11349 $number_of_metrics, 11350 $function_info_ref, 11351 $outputdir_with_slash, 11352 $_); 11353 11354 if (not $found_target) 11355 { 11356 gp_message ("debug", $subr_name, "target function not found"); 11357 } 11358 } 11359 11360} #-- End of subroutine parse_source_files 11361 11362#------------------------------------------------------------------------------ 11363# Routine to prepend \\ to selected symbols. 11364#------------------------------------------------------------------------------ 11365sub prepend_backslashes 11366{ 11367 my $subr_name = get_my_name (); 11368 11369 my ($target_string) = @_; 11370 11371 gp_message ("debug", $subr_name, "target_string on entry = $target_string"); 11372 11373 $target_string =~ s/\(/\\\(/g; 11374 $target_string =~ s/\)/\\\)/g; 11375 $target_string =~ s/\+/\\\+/g; 11376 $target_string =~ s/\[/\\\[/g; 11377 $target_string =~ s/\]/\\\]/g; 11378 $target_string =~ s/\*/\\\*/g; 11379 $target_string =~ s/\./\\\./g; 11380 $target_string =~ s/\$/\\\$/g; 11381 $target_string =~ s/\^/\\\^/g; 11382 $target_string =~ s/\#/\\\#/g; 11383 11384 gp_message ("debug", $subr_name, "target_string on return = $target_string"); 11385 11386 return ($target_string); 11387 11388} #-- End of subroutine prepend_backslashes 11389 11390#------------------------------------------------------------------------------ 11391# TBD 11392#------------------------------------------------------------------------------ 11393sub preprocess_function_files 11394{ 11395 my $subr_name = get_my_name (); 11396 11397 my ($metric_description_ref, $script_pc_metrics, $input_string, $sort_fields_ref) = @_; 11398 11399 my $outputdir = append_forward_slash ($input_string); 11400 my @sort_fields = @{ $sort_fields_ref }; 11401 11402 my $error_code; 11403 my $cmd_output; 11404 my $re; 11405 11406# TBD $outputdir .= "/"; 11407 11408 my %metric_description = %{ $metric_description_ref }; 11409 11410 for my $m (keys %metric_description) 11411 { 11412 gp_message ("debug", $subr_name, "metric_description{$m} = $metric_description{$m}"); 11413 } 11414 11415 $re = name_regex ($metric_description_ref, $script_pc_metrics, "functions", $outputdir."functions.sort.func-PC"); 11416 ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."functions.sort.func-PC.name-regex"); 11417 if ($error_code != 0 ) 11418 { 11419 gp_message ("abort", $subr_name, "execution terminated"); 11420 } 11421 11422 for my $field (@sort_fields) 11423 { 11424 $re = name_regex ($metric_description_ref, $script_pc_metrics, $field, $outputdir."$field.sort.func-PC"); 11425 ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."$field.sort.func-PC.name-regex"); 11426 if ($error_code != 0 ) 11427 { 11428 gp_message ("abort", $subr_name, "execution terminated"); 11429 } 11430 } 11431 11432 $re = name_regex ($metric_description_ref, $script_pc_metrics, "calls", $outputdir."calls.sort.func-PC"); 11433 ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calls.sort.func-PC.name-regex"); 11434 if ($error_code != 0 ) 11435 { 11436 gp_message ("abort", $subr_name, "execution terminated"); 11437 } 11438 11439 if ($g_user_settings{"calltree"}{"current_value"} eq "on") 11440 { 11441 $re = name_regex ($metric_description_ref, $script_pc_metrics, "calltree", $outputdir."calltree.sort.func-PC"); 11442 ($error_code, $cmd_output) = execute_system_cmd ("echo '$re' > $outputdir"."calltree.sort.func-PC.name-regex"); 11443 if ($error_code != 0 ) 11444 { 11445 gp_message ("abort", $subr_name, "execution terminated"); 11446 } 11447 } 11448 11449 return (0); 11450 11451} #-- End of subroutine preprocess_function_files 11452 11453#------------------------------------------------------------------------------ 11454# Print the original list with the command line options. 11455#------------------------------------------------------------------------------ 11456sub print_command_line_options 11457{ 11458 my ($identifier_ref) = @_; 11459 11460 my $identifier = ${ $identifier_ref }; 11461 my $msg; 11462 11463 $msg = "The command line options (shown for ease of reference): "; 11464 printf ("%-9s %s\n", $identifier, ucfirst ($msg)); 11465 11466 $msg = join (", ", @CopyOfARGV); 11467 printf ("%-9s %s\n", $identifier, $msg); 11468 11469# printf ("%-9s\n", $identifier); 11470 11471 return (0); 11472 11473} #-- End of subroutine print_command_line_options 11474 11475#------------------------------------------------------------------------------ 11476# Print all the errors messages in the buffer. 11477#------------------------------------------------------------------------------ 11478sub print_errors_buffer 11479{ 11480 my $subr_name = get_my_name (); 11481 11482 my ($identifier_ref) = @_; 11483 11484 my $ignore_value; 11485 my $msg; 11486 my $plural_or_single; 11487 my $identifier = ${ $identifier_ref }; 11488 11489 $plural_or_single = ($g_total_error_count > 1) ? "errors have" : "error has"; 11490 11491 if (@g_warning_msgs and $g_warnings) 11492#------------------------------------------------------------------------------ 11493# Make sure that all warnings are printed in case of an error. This is to 11494# avoid that warnings get lost in case the program terminates early. 11495#------------------------------------------------------------------------------ 11496 { 11497 $ignore_value = print_warnings_buffer (); 11498 } 11499 11500 if (not $g_options_printed) 11501#------------------------------------------------------------------------------ 11502# The options are printed as part of the warnings, so only if the warnings are 11503# not printed, we need to print them in case of errors. 11504#------------------------------------------------------------------------------ 11505 { 11506 $g_options_printed = $TRUE; 11507 $ignore_value = print_command_line_options (\$identifier); 11508 } 11509 11510 $msg = "a total of " . $g_total_error_count; 11511 $msg .= " fatal " . $plural_or_single . " been detected:"; 11512 printf ("%-9s %s\n", $identifier, ucfirst ($msg)); 11513 11514 for my $key (keys @g_error_msgs) 11515 { 11516 $msg = $g_error_msgs[$key]; 11517 printf ("%-11s %s\n", $identifier, ucfirst ($msg)); 11518 } 11519 11520 return (0); 11521 11522} #-- End of subroutine print_errors_buffer 11523 11524#------------------------------------------------------------------------------ 11525# Print the help overview 11526#------------------------------------------------------------------------------ 11527sub print_help_info 11528{ 11529 my $space = " "; 11530 11531 printf("%s\n", 11532 "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)"); 11533 printf("\n"); 11534 printf("%s\n", 11535 "Process one or more experiments to generate a directory containing the"); 11536 printf("%s\n", 11537 "index.html file that may be used to browse the experiment data."); 11538 printf("\n"); 11539 printf("%s\n", 11540 "Options:"); 11541 printf("\n"); 11542 #-------Marker line - do not go beyond this line ---------------------------- 11543 print_help_line ("--help", 11544 "Print usage information and exit."); 11545 11546 #-------Marker line - do not go beyond this line ---------------------------- 11547 print_help_line ("--version", 11548 "Print the version number and exit."); 11549 11550 #-------Marker line - do not go beyond this line ---------------------------- 11551 print_help_line ("--verbose", 11552 "Enable verbose mode to show diagnostic messages about the"); 11553 print_help_line ("", 11554 "processing of the data. By default verbose mode is disabled."); 11555 11556 #-------Marker line - do not go beyond this line ---------------------------- 11557 print_help_line ("-d [<db-vol-size>], --debug[=<db-vol-size>]", 11558 "Control the printing of run time debug information to assist with"); 11559 print_help_line ("", 11560 "the troubleshooting, or further development of this tool."); 11561 print_help_line ("", 11562 "The <db-vol-size> parameter controls the output volume and is"); 11563 print_help_line ("", 11564 "one from the list {s | S | m | M | l | L | xl | XL}."); 11565 print_help_line ("", 11566 "If db-vol-size is not specified, a modest amount of information"); 11567 print_help_line ("", 11568 "is printed. This is equivalent to select size s, or S. The"); 11569 print_help_line ("", 11570 "volume of data goes up as the size increases. Note that"); 11571 print_help_line ("", 11572 "currently l/L is equivalent to xl/XL, but this is expected to"); 11573 print_help_line ("", 11574 "change in future updates. By default debug mode is disabled."); 11575 11576 #-------Marker line - do not go beyond this line ---------------------------- 11577 print_help_line ("--highlight-percentage=<value>", 11578 "A percentage value in the interval [0,100] to select and color"); 11579 print_help_line ("", 11580 "code source lines, as well as instructions, that are within this"); 11581 print_help_line ("", 11582 "percentage of the maximum metric value(s). A value of zero"); 11583 print_help_line ("", 11584 "disables this feature. The default value is 90 (%)."); 11585 11586 #-------Marker line - do not go beyond this line ---------------------------- 11587 print_help_line ("-o <dirname>, --output=<dirname>", 11588 "Use <dirname> as the directory name to store the results in."); 11589 print_help_line ("", 11590 "In absence of this option, the default name is display.<n>.html."); 11591 print_help_line ("", 11592 "This directory is created in the current directory. The number"); 11593 print_help_line ("", 11594 "<n> is the first positive integer number not in use in this"); 11595 print_help_line ("", 11596 "naming scheme. An existing directory with the same name is not"); 11597 print_help_line ("", 11598 "overwritten. Make sure that umask is set to the correct access"); 11599 print_help_line ("", 11600 "permissions."); 11601 11602 #-------Marker line - do not go beyond this line -------------------------- 11603 print_help_line ("-O <dirname>, --overwrite=<dirname>", 11604 "Use <dirname> as the directory name to store the results in."); 11605 print_help_line ("", 11606 "In absence of this option, the default name is display.<n>.html."); 11607 print_help_line ("", 11608 "This directory is created in the current directory. The number"); 11609 print_help_line ("", 11610 "<n> is the first positive integer number not in use in this"); 11611 print_help_line ("", 11612 "naming scheme. An existing directory with the same name is"); 11613 print_help_line ("", 11614 "silently overwritten. Make sure that umask is set to the"); 11615 print_help_line ("", 11616 "correct access permissions."); 11617 11618 #-------Marker line - do not go beyond this line -------------------------- 11619 print_help_line ("-q, --quiet", 11620 "Disable the display of all warning, debug, verbose and any"); 11621 print_help_line ("", 11622 "other messages. If enabled, the settings for verbose and debug"); 11623 print_help_line ("", 11624 "are accepted, but ignored. With this option, there is no screen"); 11625 print_help_line ("", 11626 "output, other than errors. By default quiet mode is disabled"); 11627 11628 #-------Marker line - do not go beyond this line -------------------------- 11629 print_help_line ("--nowarnings", 11630 "Disable the printing of warning messages on stdout. By default"); 11631 print_help_line ("", 11632 "warning messages are printed."); 11633 11634 #-------Marker line - do not go beyond this line -------------------------- 11635 printf("\n"); 11636 printf ("%s\n","Report bugs to <https://sourceware.org/bugzilla/>"); 11637 11638 return (0); 11639 11640} #-- End of subroutine print_help_info 11641 11642#------------------------------------------------------------------------------ 11643# Print a single line as part of the help output. 11644# 11645# If the first item is not the empty string, it is considered to be the 11646# option. If the length of the option exceeds the limit set by $max_space, 11647# it is printed by itself and the text is printed on the next line. Otherwise 11648# the text follows the option. 11649# 11650# To assist with the development of the help text, we check if the total length 11651# of the line exceeds the max numbers of columns (79 according to the GNU 11652# coding standards). 11653#------------------------------------------------------------------------------ 11654sub print_help_line 11655{ 11656 my $subr_name = get_my_name (); 11657 11658 my ($item, $help_text) = @_; 11659 11660 my $length_item = length ($item); 11661 my $max_col = 79; 11662 my $max_space = 14; 11663 my $no_of_spaces; 11664 my $pad; 11665 my $space = " "; 11666 my $the_message; 11667 11668 if ($length_item > $max_col) 11669 { 11670 printf ("Error: $item is $length_item long - exceeds $max_col\n"); 11671 exit (0); 11672 } 11673 elsif ( $length_item == 0 ) 11674 { 11675 $no_of_spaces = $max_space; 11676 11677 $pad = ""; 11678 for my $i (1..$no_of_spaces) 11679 { 11680 $pad .= $space; 11681 } 11682 $the_message = $pad . $help_text; 11683 } 11684 else 11685 { 11686 if ($length_item < $max_space) 11687 { 11688 $no_of_spaces = $max_space - length ($item); 11689 $pad = ""; 11690 for my $i (1..$no_of_spaces) 11691 { 11692 $pad .= $space; 11693 } 11694 $the_message = $item . $pad . $help_text; 11695 } 11696 else 11697 { 11698 $pad = ""; 11699 for my $i (1..$max_space) 11700 { 11701 $pad .= $space; 11702 } 11703 printf("%s\n", $item); 11704 $the_message = $pad . $help_text; 11705 } 11706 } 11707 11708 if (length ($the_message) <= $max_col) 11709 { 11710 printf ("%s\n", $the_message); 11711 } 11712 else 11713 { 11714 my $delta = length ($the_message) - $max_col; 11715 printf ("%s\n", "$the_message - exceeds $max_col by $delta"); 11716 exit (0); 11717 } 11718 11719 11720 return (0); 11721 11722} #-- End of subroutine print_help_line 11723 11724#------------------------------------------------------------------------------ 11725# Print the meta data for each experiment directory. 11726#------------------------------------------------------------------------------ 11727sub print_meta_data_experiments 11728{ 11729 my $subr_name = get_my_name (); 11730 11731 my ($mode) = @_; 11732 11733 for my $exp (sort keys %g_exp_dir_meta_data) 11734 { 11735 for my $meta (sort keys %{$g_exp_dir_meta_data{$exp}}) 11736 { 11737 gp_message ($mode, $subr_name, "$exp => $meta = $g_exp_dir_meta_data{$exp}{$meta}"); 11738 } 11739 } 11740 11741 return (0); 11742 11743} #-- End of subroutine print_meta_data_experiments 11744 11745#------------------------------------------------------------------------------ 11746# Brute force subroutine that prints the contents of a structure with function 11747# level information. This version is for a top level array structure, 11748# followed by a hash. 11749#------------------------------------------------------------------------------ 11750sub print_metric_function_array 11751{ 11752 my $subr_name = get_my_name (); 11753 11754 my ($metric, $struct_type_name, $target_structure_ref) = @_; 11755 11756 my @target_structure = @{$target_structure_ref}; 11757 11758 gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:"); 11759 11760 for my $fields (sort keys @target_structure) 11761 { 11762 for my $elems (sort keys % {$target_structure[$fields]}) 11763 { 11764 my $msg = $struct_type_name."{$metric}[$fields]{$elems} = "; 11765 $msg .= $target_structure[$fields]{$elems}; 11766 gp_message ("debugXL", $subr_name, $msg); 11767 } 11768 } 11769 11770 return (0); 11771 11772} #-- End of subroutine print_metric_function_array 11773 11774#------------------------------------------------------------------------------ 11775# Brute force subroutine that prints the contents of a structure with function 11776# level information. This version is for a top level hash structure. The 11777# next level may be another hash, or an array. 11778#------------------------------------------------------------------------------ 11779sub print_metric_function_hash 11780{ 11781 my $subr_name = get_my_name (); 11782 11783 my ($sub_struct_type, $metric, $struct_type_name, $target_structure_ref) = @_; 11784 11785 my %target_structure = %{$target_structure_ref}; 11786 11787 gp_message ("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:"); 11788 11789 for my $fields (sort keys %target_structure) 11790 { 11791 gp_message ("debugXL", $subr_name, "metric = $metric fields = $fields"); 11792 if ($sub_struct_type eq "hash_hash") 11793 { 11794 for my $elems (sort keys %{$target_structure{$fields}}) 11795 { 11796 my $txt = $struct_type_name."{$metric}{$fields}{$elems} = "; 11797 $txt .= $target_structure{$fields}{$elems}; 11798 gp_message ("debugXL", $subr_name, $txt); 11799 } 11800 } 11801 elsif ($sub_struct_type eq "hash_array") 11802 { 11803 my $values = ""; 11804 for my $elems (sort keys @{$target_structure{$fields}}) 11805 { 11806 $values .= "$target_structure{$fields}[$elems] "; 11807 } 11808 gp_message ("debugXL", $subr_name, $struct_type_name."{$metric}{$fields} = $values"); 11809 } 11810 else 11811 { 11812 my $msg = "sub-structure type '$sub_struct_type' is not supported"; 11813 gp_message ("assertion", $subr_name, $msg); 11814 } 11815 } 11816 11817 return (0); 11818 11819} #-- End of subroutine print_metric_function_hash 11820 11821#------------------------------------------------------------------------------ 11822# Print the opening message. 11823#------------------------------------------------------------------------------ 11824sub print_opening_message 11825{ 11826 my $subr_name = get_my_name (); 11827#------------------------------------------------------------------------------ 11828# Since the second argument is an array, we pass it in by reference. The 11829# alternative is to make it the last argument. 11830#------------------------------------------------------------------------------ 11831 my ($outputdir, $exp_dir_list_ref, $time_percentage_multiplier) = @_; 11832 11833 my @exp_dir_list = @{$exp_dir_list_ref}; 11834 11835 my $msg; 11836 my $no_of_dirs = scalar (@exp_dir_list); 11837#------------------------------------------------------------------------------ 11838# Build a comma separated list with all directory names. If there is only one 11839# entry, the leading comma will not be inserted. 11840#------------------------------------------------------------------------------ 11841 my $dir_list = join (", ", @exp_dir_list); 11842 11843#------------------------------------------------------------------------------ 11844# If there are at least two entries, find the last comma and replace it by 11845# " and". Note that we know there is at least one comma, so the value 11846# returned by rindex () cannot be -1. 11847#------------------------------------------------------------------------------ 11848 if ($no_of_dirs > 1) 11849 { 11850 my $last_comma = rindex ($dir_list, ","); 11851 my $ignore_value = substr ($dir_list, $last_comma, 1, " and"); 11852 } 11853 $msg = "start $tool_name, generating directory $outputdir from $dir_list"; 11854 11855 gp_message ("verbose", $subr_name, $msg); 11856 11857 if ($time_percentage_multiplier < 1.0) 11858 { 11859 $msg = "Handle at least "; 11860 } 11861 else 11862 { 11863 $msg = "Handle "; 11864 } 11865 11866 $msg .= ($time_percentage_multiplier*100.0)."% of the time"; 11867 11868 gp_message ("verbose", $subr_name, $msg); 11869 11870} #-- End of subroutine print_opening_message 11871 11872#------------------------------------------------------------------------------ 11873# TBD. 11874#------------------------------------------------------------------------------ 11875sub print_program_header 11876{ 11877 my $subr_name = get_my_name (); 11878 11879 my ($mode, $tool_name, $binutils_version) = @_; 11880 11881 my $header_limit = 60; 11882 my $dashes = "-"; 11883 11884#------------------------------------------------------------------------------ 11885# Generate the dashed line 11886#------------------------------------------------------------------------------ 11887 for (2 .. $header_limit) 11888 { 11889 $dashes .= "-"; 11890 } 11891 11892 gp_message ($mode, $subr_name, $dashes); 11893 gp_message ($mode, $subr_name, "Tool name: $tool_name"); 11894 gp_message ($mode, $subr_name, "Version : $binutils_version"); 11895 gp_message ($mode, $subr_name, "Date : " . localtime ()); 11896 gp_message ($mode, $subr_name, $dashes); 11897 11898} #-- End of subroutine print_program_header 11899 11900#------------------------------------------------------------------------------ 11901# Print a comment string, followed by the values of the options. The list 11902# with the keywords is sorted alphabetically. 11903# 11904# The value stored in $mode is passed on to gp_message (). The intended use 11905# for this is to call this function in verbose and/or debug mode. 11906# 11907# The comment string is converted to uppercase. 11908# 11909# In case the length of the comment exceeds the length of the dashed line, 11910# the comment line is allowed to stick out to the right. 11911# 11912# If the length of the comment is less than the dashed line, it is centered 11913# relative to the # length of the dashed line. 11914 11915# If the length of the comment and this line do not divide, an extra space is 11916# added to the left of the comment. 11917# 11918# For example, if the comment is 55 long, there are 5 spaces to be distributed. 11919# There will be 3 spaces, followed by the comment. 11920#------------------------------------------------------------------------------ 11921sub print_table_user_settings 11922{ 11923 my $subr_name = get_my_name (); 11924 11925 my ($mode, $comment) = @_; 11926 11927 my $data_type; 11928 my $debug_size_value = $g_user_settings{"debug"}{"current_value"}; 11929 my $db_size; 11930 my $defined; 11931 my $keyword; 11932 my $leftover; 11933 my $padding; 11934 my $user_option; 11935 my $value; 11936 11937 my $HEADER_LIMIT = 79; 11938 my $header = sprintf ("%-20s %-22s %8s %s", 11939 "keyword", "option", "user set", "internal value"); 11940 11941#------------------------------------------------------------------------------ 11942# Generate the dashed line 11943#------------------------------------------------------------------------------ 11944 my $dashes = "-"; 11945 for (2 .. $HEADER_LIMIT) 11946 { 11947 $dashes .= "-"; 11948 } 11949 11950#------------------------------------------------------------------------------ 11951# Determine the padding needed to the left of the comment. 11952#------------------------------------------------------------------------------ 11953 my $length_comment = length ($comment); 11954 11955 $leftover = $length_comment%2; 11956 11957 if ($length_comment <= ($HEADER_LIMIT-2)) 11958 { 11959 $padding = ($HEADER_LIMIT - $length_comment + $leftover)/2; 11960 } 11961 else 11962 { 11963 $padding = 0; 11964 } 11965 11966#------------------------------------------------------------------------------ 11967# Generate the first blank part of the line. 11968#------------------------------------------------------------------------------ 11969 my $blank_line = ""; 11970 for (1 .. $padding) 11971 { 11972 $blank_line .= " "; 11973 } 11974 11975#------------------------------------------------------------------------------ 11976# Add the comment line with the first letter in uppercase. 11977#------------------------------------------------------------------------------ 11978 my $final_comment = $blank_line.ucfirst ($comment); 11979 11980 gp_message ($mode, $subr_name, $dashes); 11981 gp_message ($mode, $subr_name, $final_comment); 11982 gp_message ($mode, $subr_name, $dashes); 11983 gp_message ($mode, $subr_name, $header); 11984 gp_message ($mode, $subr_name, $dashes); 11985 11986#------------------------------------------------------------------------------ 11987# Print a line for each option. The list is sorted alphabetically. 11988#------------------------------------------------------------------------------ 11989 for my $key (sort keys %g_user_settings) 11990 { 11991 $keyword = $key; 11992 $user_option = $g_user_settings{$key}{"option"}; 11993 $defined = ($g_user_settings{$key}{"defined"} ? "set" : "not set"); 11994 $data_type = $g_user_settings{$key}{"data_type"}; 11995 11996 if (defined ($g_user_settings{$key}{"current_value"})) 11997 { 11998 $value = $g_user_settings{$key}{"current_value"}; 11999 if ($data_type eq "boolean") 12000 { 12001 $value = $value ? "on" : "off"; 12002 } 12003#------------------------------------------------------------------------------ 12004# In case of the debug option, we add the "(size)" string to remind the user 12005# that this is the size. 12006#------------------------------------------------------------------------------ 12007 if ($key eq "debug") 12008 { 12009 $db_size = ($debug_size_value eq "on") ? "s" : $debug_size_value; 12010 $value = $db_size . " (size)"; 12011 } 12012 } 12013 else 12014 { 12015 $value = "undefined"; 12016 } 12017 12018 my $print_line = sprintf ("%-20s %-22s %8s %s", 12019 $keyword, $user_option, $defined, $value); 12020 12021 gp_message ($mode, $subr_name, $print_line); 12022 } 12023} #-- End of subroutine print_table_user_settings 12024 12025#------------------------------------------------------------------------------ 12026# Dump the contents of nested hash "g_user_settings". Some simple formatting 12027# is applied to make it easier to distinguish the various values. 12028#------------------------------------------------------------------------------ 12029sub print_user_settings 12030{ 12031 my $subr_name = get_my_name (); 12032 12033 my ($mode, $comment) = @_; 12034 12035 my $keyword_value_pair; 12036 12037 gp_message ($mode, $subr_name, $comment); 12038 12039 for my $key (keys %g_user_settings) 12040 { 12041 my $print_line = sprintf ("%-20s =>", $key); 12042 for my $fields (sort keys %{ $g_user_settings{$key} }) 12043 { 12044 if (defined ($g_user_settings{$key}{$fields})) 12045 { 12046 $keyword_value_pair = $fields." = ".$g_user_settings{$key}{$fields}; 12047 } 12048 else 12049 { 12050 $keyword_value_pair = $fields." = ". "undefined"; 12051 } 12052 $print_line = join (" ", $print_line, $keyword_value_pair); 12053 } 12054 gp_message ($mode, $subr_name, $print_line); 12055 } 12056} #-- End of subroutine print_user_settings 12057 12058#------------------------------------------------------------------------------ 12059# Print the version number and license information. 12060#------------------------------------------------------------------------------ 12061sub print_version_info 12062{ 12063 print "$version_info\n"; 12064 print "Copyright (C) 2023 Free Software Foundation, Inc.\n"; 12065 print "License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>.\n"; 12066 print "This is free software: you are free to change and redistribute it.\n"; 12067 print "There is NO WARRANTY, to the extent permitted by law.\n"; 12068 12069 return (0); 12070 12071} #-- End of subroutine print_version_info 12072 12073#------------------------------------------------------------------------------ 12074# Dump all the warning messages in the buffer. 12075#------------------------------------------------------------------------------ 12076sub print_warnings_buffer 12077{ 12078 my $subr_name = get_my_name (); 12079 12080 my $ignore_value; 12081 my $msg; 12082 12083 if (not $g_options_printed) 12084#------------------------------------------------------------------------------ 12085# Only if the options have not yet been printed, print them. 12086#------------------------------------------------------------------------------ 12087 { 12088 $g_options_printed = $TRUE; 12089 $ignore_value = print_command_line_options (\$g_warn_keyword); 12090 } 12091 12092 for my $i (keys @g_warning_msgs) 12093 { 12094 $msg = $g_warning_msgs[$i]; 12095 if ($msg =~ /^$g_html_new_line/) 12096 { 12097 $msg =~ s/$g_html_new_line//; 12098 printf ("%-9s\n", $g_warn_keyword); 12099 } 12100 printf ("%-9s %s\n", $g_warn_keyword, ucfirst ($msg)); 12101 } 12102 12103 return (0); 12104 12105} #-- End of subroutine print_warnings_buffer 12106 12107#------------------------------------------------------------------------------ 12108# Process the call tree input data and generate HTML output. 12109#------------------------------------------------------------------------------ 12110sub process_calltree 12111{ 12112 my $subr_name = get_my_name (); 12113 12114 my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref, 12115 $input_string) = @_; 12116 12117 my @function_info = @{ $function_info_ref }; 12118 my %function_address_info = %{ $function_address_info_ref }; 12119 my %addressobjtextm = %{ $addressobjtextm_ref }; 12120 12121 my $outputdir = append_forward_slash ($input_string); 12122 12123 my @call_tree_data = (); 12124 12125 my $LANG = $g_locale_settings{"LANG"}; 12126 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 12127 12128 my $infile = $outputdir . "calltree"; 12129 my $outfile = $outputdir . "calltree.html"; 12130 12131 open (CALL_TREE_IN, "<", $infile) 12132 or die ("Not able to open calltree file $infile for reading - '$!'"); 12133 gp_message ("debug", $subr_name, "opened file $infile for reading"); 12134 12135 open (CALL_TREE_OUT, ">", $outfile) 12136 or die ("Not able to open $outfile for writing - '$!'"); 12137 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 12138 12139 gp_message ("debug", $subr_name, "building calltree file $outfile"); 12140 12141#------------------------------------------------------------------------------ 12142# The directory name is potentially used below, but since it is a constant, 12143# we get it here and only once. 12144#------------------------------------------------------------------------------ 12145# my ($ignore_file_name, $directory_name, $ignore_suffix) = fileparse ($infile,""); 12146# gp_message ("debug", $subr_name, "directory_name = $directory_name"); 12147 12148#------------------------------------------------------------------------------ 12149# Generate some of the structures used in the HTML output. 12150#------------------------------------------------------------------------------ 12151 my $file_title = "Call Tree overview"; 12152 my $html_header = ${ create_html_header (\$file_title) }; 12153 my $html_home_right = ${ generate_home_link ("right") }; 12154 12155 my $page_title = "Call Tree View"; 12156 my $size_text = "h2"; 12157 my $position_text = "center"; 12158 my $html_title_header = ${ generate_a_header ( 12159 \$page_title, 12160 \$size_text, 12161 \$position_text) }; 12162 12163#------------------------------------------------------------------------------ 12164# Get the acknowledgement, return to main link, and final html statements. 12165#------------------------------------------------------------------------------ 12166 my $html_home_left = ${ generate_home_link ("left") }; 12167 my $html_acknowledgement = ${ create_html_credits () }; 12168 my $html_end = ${ terminate_html_document () }; 12169 12170#------------------------------------------------------------------------------ 12171# Read all of the file into array with the name call_tree_data. 12172#------------------------------------------------------------------------------ 12173 chomp (@call_tree_data = <CALL_TREE_IN>); 12174 close (CALL_TREE_IN); 12175 12176#------------------------------------------------------------------------------ 12177#------------------------------------------------------------------------------ 12178# Process the data here and generate the HTML lines. 12179#------------------------------------------------------------------------------ 12180#------------------------------------------------------------------------------ 12181 12182#------------------------------------------------------------------------------ 12183# Print the top part of the HTML file. 12184#------------------------------------------------------------------------------ 12185 print CALL_TREE_OUT $html_header; 12186 print CALL_TREE_OUT $html_home_right; 12187 print CALL_TREE_OUT $html_title_header; 12188 12189#------------------------------------------------------------------------------ 12190# Print the generated HTML structures here. 12191#------------------------------------------------------------------------------ 12192## print CALL_TREE_OUT "$_" for @whatever; 12193## print CALL_TREE_OUT "<pre>\n"; 12194## print CALL_TREE_OUT "$_\n" for @whatever2; 12195## print CALL_TREE_OUT "</pre>\n"; 12196 12197#------------------------------------------------------------------------------ 12198# Print the last part of the HTML file. 12199#------------------------------------------------------------------------------ 12200 print CALL_TREE_OUT $html_home_left; 12201 print CALL_TREE_OUT "<br>\n"; 12202 print CALL_TREE_OUT $html_acknowledgement; 12203 print CALL_TREE_OUT $html_end; 12204 12205 close (CALL_TREE_OUT); 12206 12207 return (0); 12208 12209} #-- End of subroutine process_calltree 12210 12211#------------------------------------------------------------------------------ 12212# Process the generated experiment info file(s). 12213#------------------------------------------------------------------------------ 12214sub process_experiment_info 12215{ 12216 my $subr_name = get_my_name (); 12217 12218 my ($experiment_data_ref) = @_; 12219 12220 my @exp_info; 12221 my @experiment_data = @{ $experiment_data_ref }; 12222 12223 my $exp_id; 12224 my $exp_name; 12225 my $exp_data_file; 12226 my $input_line; 12227 my $target_cmd; 12228 my $hostname ; 12229 my $OS; 12230 my $page_size; 12231 my $architecture; 12232 my $start_date; 12233 my $end_experiment; 12234 my $data_collection_duration; 12235 my $total_thread_time; 12236 my $user_cpu_time; 12237 my $user_cpu_percentage; 12238 my $system_cpu_time; 12239 my $system_cpu_percentage; 12240 my $sleep_time; 12241 my $sleep_percentage; 12242 12243#------------------------------------------------------------------------------ 12244# Define the regular expressions used to capture the info. 12245#------------------------------------------------------------------------------ 12246# Target command (64-bit): './../bindir/mxv-pthreads.exe -m 3000 -n 2000 -t 2' 12247 12248 my $target_cmd_regex = '\s*Target command\s+(\(.+\)):\s+\'(.+)\''; 12249 12250# Host `ruudvan-vm-haswell-2-20210609', OS `Linux 5.4.17-2102.202.5.el8uek.x86_64', page size 4096, architecture `x86_64' 12251 12252 my $host_system_regex = '\s*Host\s+\`(.+)\',\s+OS\s+\`(.+)\',\s+page size\s+(\d+),\s+architecture\s+\`(.+)\''; 12253 12254# Experiment started Mon Aug 30 13:03:20 2021 12255 12256 my $start_date_regex = '\s*Experiment started\s+(.+)'; 12257 12258# Experiment Ended: 1.812441219 12259 12260 my $end_experiment_regex = '\s*Experiment Ended:\s+(.+)'; 12261 12262# Data Collection Duration: 1.812441219 12263 12264 my $data_collection_duration_regex = '\s*Data Collection Duration:\s+(.+)'; 12265 12266# Total Thread Time (sec.): 1.812 12267 12268 my $total_thread_time_regex = '\s*Total Thread Time (sec.):\s+(.+)'; 12269 12270# User CPU: 1.685 ( 95.0%) 12271 12272 my $user_cpu_regex = '\s*User CPU:\s+(.+)\s+\(\s*(.+)\)'; 12273 12274# System CPU: 0.088 ( 5.0%) 12275 12276 my $system_cpu_regex = '\s*System CPU:\s+(.+)\s+\(\s*(.+)\)'; 12277 12278# Sleep: 0. ( 0. %) 12279 12280 my $sleep_regex = '\s*Sleep:\s+(.+)\s+\(\s*(.+)\)'; 12281 12282#------------------------------------------------------------------------------ 12283# Scan the experiment data and select the info of interest. 12284#------------------------------------------------------------------------------ 12285 for my $i (sort keys @experiment_data) 12286 { 12287 $exp_id = $experiment_data[$i]{"exp_id"}; 12288 $exp_name = $experiment_data[$i]{"exp_name_full"}; 12289 $exp_data_file = $experiment_data[$i]{"exp_data_file"}; 12290 12291 my $msg = "exp_id = $exp_id name = $exp_name file = $exp_data_file"; 12292 gp_message ("debug", $subr_name, $msg); 12293 12294 open (EXPERIMENT_INFO, "<", $exp_data_file) 12295 or die ("$subr_name - unable to open file $exp_data_file for reading '$!'"); 12296 gp_message ("debug", $subr_name, "opened file $exp_data_file for reading"); 12297 12298 chomp (@exp_info = <EXPERIMENT_INFO>); 12299 12300#------------------------------------------------------------------------------ 12301# Process the info for the current experiment. 12302#------------------------------------------------------------------------------ 12303 for my $line (0 .. $#exp_info) 12304 { 12305 $input_line = $exp_info[$line]; 12306 12307 my $msg = "exp_id = $exp_id: input_line = $input_line"; 12308 gp_message ("debugM", $subr_name, $msg); 12309 12310 if ($input_line =~ /$target_cmd_regex/) 12311 { 12312 $target_cmd = $2; 12313 gp_message ("debugM", $subr_name, "$exp_id => $target_cmd"); 12314 $experiment_data[$i]{"target_cmd"} = $target_cmd; 12315 } 12316 elsif ($input_line =~ /$host_system_regex/) 12317 { 12318 $hostname = $1; 12319 $OS = $2; 12320 $page_size = $3; 12321 $architecture = $4; 12322 gp_message ("debugM", $subr_name, "$exp_id => $hostname $OS $page_size $architecture"); 12323 $experiment_data[$i]{"hostname"} = $hostname; 12324 $experiment_data[$i]{"OS"} = $OS; 12325 $experiment_data[$i]{"page_size"} = $page_size; 12326 $experiment_data[$i]{"architecture"} = $architecture; 12327 } 12328 elsif ($input_line =~ /$start_date_regex/) 12329 { 12330 $start_date = $1; 12331 gp_message ("debugM", $subr_name, "$exp_id => $start_date"); 12332 $experiment_data[$i]{"start_date"} = $start_date; 12333 } 12334 elsif ($input_line =~ /$end_experiment_regex/) 12335 { 12336 $end_experiment = $1; 12337 gp_message ("debugM", $subr_name, "$exp_id => $end_experiment"); 12338 $experiment_data[$i]{"end_experiment"} = $end_experiment; 12339 } 12340 elsif ($input_line =~ /$data_collection_duration_regex/) 12341 { 12342 $data_collection_duration = $1; 12343 gp_message ("debugM", $subr_name, "$exp_id => $data_collection_duration"); 12344 $experiment_data[$i]{"data_collection_duration"} = $data_collection_duration; 12345 } 12346#------------------------------------------------------------------------------ 12347# Start Label: Total 12348# End Label: Total 12349# Start Time (sec.): 0.000 12350# End Time (sec.): 1.812 12351# Duration (sec.): 1.812 12352# Total Thread Time (sec.): 1.812 12353# Average number of Threads: 1.000 12354# 12355# Process Times (sec.): 12356# User CPU: 1.666 ( 91.9%) 12357# System CPU: 0.090 ( 5.0%) 12358# Trap CPU: 0. ( 0. %) 12359# User Lock: 0. ( 0. %) 12360# Data Page Fault: 0. ( 0. %) 12361# Text Page Fault: 0. ( 0. %) 12362# Kernel Page Fault: 0. ( 0. %) 12363# Stopped: 0. ( 0. %) 12364# Wait CPU: 0. ( 0. %) 12365# Sleep: 0.056 ( 3.1%) 12366#------------------------------------------------------------------------------ 12367 elsif ($input_line =~ /$total_thread_time_regex/) 12368 { 12369 $total_thread_time = $1; 12370 gp_message ("debugM", $subr_name, "$exp_id => $total_thread_time"); 12371 $experiment_data[$i]{"total_thread_time"} = $total_thread_time; 12372 } 12373 elsif ($input_line =~ /$user_cpu_regex/) 12374 { 12375 $user_cpu_time = $1; 12376 $user_cpu_percentage = $2; 12377 gp_message ("debugM", $subr_name, "$exp_id => $user_cpu_time $user_cpu_percentage"); 12378 $experiment_data[$i]{"user_cpu_time"} = $user_cpu_time . " (" . $user_cpu_percentage . ")"; 12379 $experiment_data[$i]{"user_cpu_percentage"} = $user_cpu_percentage; 12380 } 12381 elsif ($input_line =~ /$system_cpu_regex/) 12382 { 12383 $system_cpu_time = $1; 12384 $system_cpu_percentage = $2; 12385 gp_message ("debugM", $subr_name, "$exp_id => $system_cpu_time $system_cpu_percentage"); 12386 $experiment_data[$i]{"system_cpu_time"} = $system_cpu_time . " (" . $system_cpu_percentage . ")"; 12387 $experiment_data[$i]{"system_cpu_percentage"} = $system_cpu_percentage; 12388 } 12389 elsif ($input_line =~ /$sleep_regex/) 12390 { 12391 $sleep_time = $1; 12392 $sleep_percentage = $2; 12393 $experiment_data[$i]{"sleep_time"} = $sleep_time . " (" . $sleep_percentage . ")"; 12394 $experiment_data[$i]{"sleep_percentage"} = $sleep_percentage; 12395 12396 my $msg = "exp_id = $exp_id => sleep_time = $sleep_time " . 12397 "sleep_percentage = $sleep_percentage"; 12398 gp_message ("debugM", $subr_name, $msg); 12399 } 12400 } 12401 } 12402 12403 for my $keys (0 .. $#experiment_data) 12404 { 12405 for my $fields (sort keys %{ $experiment_data[$keys] }) 12406 { 12407 my $msg = "experiment_data[$keys]{$fields} = " . 12408 $experiment_data[$keys]{$fields}; 12409 gp_message ("debugM", $subr_name, $msg); 12410 } 12411 } 12412 12413 return (\@experiment_data); 12414 12415} #-- End of subroutine process_experiment_info 12416 12417#------------------------------------------------------------------------------ 12418# TBD 12419#------------------------------------------------------------------------------ 12420sub process_function_files 12421{ 12422 my $subr_name = get_my_name (); 12423 12424 my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier, 12425 $summary_metrics, $process_all_functions, $elf_loadobjects_found, 12426 $outputdir, $sort_fields_ref, $function_info_ref, 12427 $function_address_and_index_ref, $LINUX_vDSO_ref, 12428 $metric_description_ref, $elf_arch, $base_va_executable, 12429 $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_; 12430 12431 my $old_fsummary; 12432 my $total_attributed_time; 12433 my $current_attributed_time; 12434 my $value; 12435 12436 my @exp_dir_list = @{ $exp_dir_list_ref }; 12437 my @function_info = @{ $function_info_ref }; 12438 my %function_address_and_index = %{ $function_address_and_index_ref }; 12439 my @sort_fields = @{ $sort_fields_ref }; 12440 my %metric_description = %{ $metric_description_ref }; 12441 my %elf_rats = %{ $elf_rats_ref }; 12442 12443#------------------------------------------------------------------------------ 12444# The regex section. 12445# 12446# TBD: Remove the part regarding clones. Legacy. 12447#------------------------------------------------------------------------------ 12448 my $find_clone_regex = '^(.*)(\s+--\s+cloned\s+version\s+\[)([^]]+)(\])'; 12449 my $remove_number_regex = '^\d+:'; 12450 my $replace_quote_regex = '"/\"'; 12451 12452 my %addressobj_index = (); 12453 my %function_address_info = (); 12454 my $function_address_info_ref; 12455 12456 $outputdir = append_forward_slash ($outputdir); 12457 12458 my %functions_per_metric_indexes = (); 12459 my $functions_per_metric_indexes_ref; 12460 12461 my %functions_per_metric_first_index = (); 12462 my $functions_per_metric_first_index_ref; 12463 12464 my %routine_list = (); 12465 my %handled_routines = (); 12466 12467#------------------------------------------------------------------------------ 12468# TBD: Name cleanup needed. 12469#------------------------------------------------------------------------------ 12470 12471 my $number_of_metrics; 12472 my $expr_name; 12473 my $routine; 12474 my $tmp; 12475 my $loadobj; 12476 my $PCA; 12477 my $address_field; 12478 my $limit_txt; 12479 my $n_metrics_text; 12480 my $disfile; 12481 my $srcfile; 12482 my $RIN; 12483 my $gp_listings_cmd; 12484 my $gp_display_text_cmd; 12485 my $ignore_value; 12486 12487 my $result_file = $outputdir . "gp-listings.out"; 12488 my $gp_error_file = $outputdir . "gp-listings.err"; 12489 12490 my $convert_to_dot = $g_locale_settings{"convert_to_dot"}; 12491 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 12492 my $length_of_string = length ($outputdir); 12493 12494 $expr_name = join (" ", @exp_dir_list); 12495 12496 gp_message ("debug", $subr_name, "expr_name = $expr_name"); 12497 12498#------------------------------------------------------------------------------ 12499# Loop over the files in $outputdir. 12500#------------------------------------------------------------------------------ 12501 while (glob ($outputdir.'*.sort.func-PC')) 12502 { 12503 my $metric; 12504 my $infile; 12505 my $ignore_value; 12506 my $suffix_not_used; 12507 12508 $infile = $_; 12509 12510 ($metric, $ignore_value, $suffix_not_used) = fileparse ($infile, ".sort.func-PC"); 12511 12512 gp_message ("debugXL", $subr_name, "suffix_not_used = $suffix_not_used"); 12513 gp_message ("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-"); 12514 12515 # Function_info creates the functions files from the PC ones 12516 # as well as culling PC and metric information 12517 12518 ($function_address_info_ref, 12519 $functions_per_metric_first_index_ref, 12520 $functions_per_metric_indexes_ref) = function_info ( 12521 $outputdir, 12522 $infile, 12523 $metric, 12524 $LINUX_vDSO_ref); 12525 12526 @{$function_address_info{$metric}} = @{$function_address_info_ref}; 12527 %{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref}; 12528 %{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref}; 12529 12530 $ignore_value = print_metric_function_array ($metric, 12531 "function_address_info", 12532 \@{$function_address_info{$metric}}); 12533 $ignore_value = print_metric_function_hash ("hash_hash", $metric, 12534 "functions_per_metric_first_index", 12535 \%{$functions_per_metric_first_index{$metric}}); 12536 $ignore_value = print_metric_function_hash ("hash_array", $metric, 12537 "functions_per_metric_indexes", 12538 \%{$functions_per_metric_indexes{$metric}}); 12539 } 12540 12541#------------------------------------------------------------------------------ 12542# Get header info for use in post processing er_html output 12543#------------------------------------------------------------------------------ 12544 gp_message ("debugXL", $subr_name, "get_hdr_info section"); 12545 12546 get_hdr_info ($outputdir, $outputdir."functions.sort.func"); 12547 12548 for my $field (@sort_fields) 12549 { 12550 get_hdr_info ($outputdir, $outputdir."$field.sort.func"); 12551 } 12552 12553#------------------------------------------------------------------------------ 12554# Caller-callee 12555#------------------------------------------------------------------------------ 12556 get_hdr_info ($outputdir, $outputdir."calls.sort.func"); 12557 12558#------------------------------------------------------------------------------ 12559# Calltree 12560#------------------------------------------------------------------------------ 12561 if ($g_user_settings{"calltree"}{"current_value"} eq "on") 12562 { 12563 get_hdr_info ($outputdir, $outputdir."calltree.sort.func"); 12564 } 12565 12566 gp_message ("debug", $subr_name, "process functions"); 12567 12568 my $scriptfile = $outputdir.'gp-script'; 12569 my $script_metrics = "$summary_metrics"; 12570 my $func_limit = $g_user_settings{"func_limit"}{"current_value"}; 12571 12572 open (SCRIPT, ">", $scriptfile) 12573 or die ("Unable to create script file $scriptfile - '$!'"); 12574 gp_message ("debug", $subr_name, "opened script file $scriptfile for writing"); 12575 12576 print SCRIPT "# limit $func_limit\n"; 12577 print SCRIPT "limit $func_limit\n"; 12578 print SCRIPT "# thread_select all\n"; 12579 print SCRIPT "thread_select all\n"; 12580 print SCRIPT "# metrics $script_metrics\n"; 12581 print SCRIPT "metrics $script_metrics\n"; 12582 12583 for my $metric (@sort_fields) 12584 { 12585 gp_message ("debug", $subr_name, "handling $metric->$metric_description{$metric}"); 12586 12587 $total_attributed_time = 0; 12588 $current_attributed_time = 0; 12589 12590 $value = $function_address_info{$metric}[0]{"metric_value"}; # <Total> 12591 if ($convert_to_dot) 12592 { 12593 $value =~ s/$decimal_separator/\./; 12594 } 12595 $total_attributed_time = $value; 12596 12597#------------------------------------------------------------------------------ 12598# start at 1 - skipping <Total> 12599#------------------------------------------------------------------------------ 12600 for my $INDEX (1 .. $#{$function_address_info{$metric}}) 12601 { 12602#------------------------------------------------------------------------------ 12603#Looking to handle at least 99% of the time - or what the user asked for 12604#------------------------------------------------------------------------------ 12605 $value = $function_address_info{$metric}[$INDEX]{"metric_value"}; 12606 $routine = $function_address_info{$metric}[$INDEX]{"routine"}; 12607 12608 gp_message ("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time"); 12609 gp_message ("debugXL", $subr_name, " (found routine $routine : value $value)"); 12610 12611 if ($convert_to_dot) 12612 { 12613 $value =~ s/$decimal_separator/\./; 12614 } 12615 12616 if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or 12617 ( ($total_attributed_time == 0) and ($value>0) ) or 12618 $process_all_functions) 12619 { 12620 $PCA = $function_address_info{$metric}[$INDEX]{"PC Address"}; 12621 12622 if (not exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA})) 12623 { 12624 gp_message ("debugXL", $subr_name, "not exists: functions_per_metric_first_index{$metric}{$routine}{$PCA}"); 12625 } 12626 if (not exists ($function_address_and_index{$routine}{$PCA})) 12627 { 12628 gp_message ("debugXL", $subr_name, "not exists: function_address_and_index{$routine}{$PCA}"); 12629 } 12630 12631 if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and 12632 exists ($function_address_and_index{$routine}{$PCA})) 12633 { 12634#------------------------------------------------------------------------------ 12635# handled_routines now contains $RI from "first_metric" (?) 12636#------------------------------------------------------------------------------ 12637 $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1; 12638 my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; 12639 if ($metric_description{$metric} =~ /Exclusive Total CPU Time/) 12640 { 12641 $routine_list{$routine} = 1 12642 } 12643 12644 gp_message ("debugXL", $subr_name, " $routine is candidate"); 12645 } 12646 else 12647 { 12648 die ("internal error for metric $metric and routine $routine"); 12649 } 12650 12651 $current_attributed_time += $value; 12652 } 12653 } 12654 } 12655#------------------------------------------------------------------------------ 12656# Sort numerically in ascending order. 12657#------------------------------------------------------------------------------ 12658 for my $routine_index (sort {$a <=> $b} keys %handled_routines) 12659 { 12660 $routine = $function_info[$routine_index]{"routine"}; 12661 gp_message ("debugXL", $subr_name, "routine_index = $routine_index routine = $routine"); 12662 next unless $routine_list{$routine}; 12663 12664# not used $source = $function_info[$routine_index]{"Source File"}; 12665 12666 $function_info[$routine_index]{"srcline"} = ""; 12667 $address_field = $function_info[$routine_index]{"addressobjtext"}; 12668 12669#------------------------------------------------------------------------------ 12670# Strip the internal number from the address field. 12671#------------------------------------------------------------------------------ 12672 $address_field =~ s/$remove_number_regex//; 12673 12674## $disfile = "file\.$routine_index\.dis"; 12675 $disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"}; 12676 $srcfile = ""; 12677 $srcfile = "file\.$routine_index\.src.txt"; 12678 12679#------------------------------------------------------------------------------ 12680# If the file is unknown, we can disassemble anyway and add disassembly 12681# to the script. 12682#------------------------------------------------------------------------------ 12683 print SCRIPT "# outfile $outputdir"."$disfile\n"; 12684 print SCRIPT "outfile $outputdir"."$disfile\n"; 12685#------------------------------------------------------------------------------ 12686# TBD: Legacy. Not sure why this is needed, but it won't harm things. I hope. 12687#------------------------------------------------------------------------------ 12688 $tmp = $routine; 12689 $tmp =~ s/$replace_quote_regex//g; 12690 print SCRIPT "# disasm \"$tmp\" $address_field\n"; 12691#------------------------------------------------------------------------------ 12692## TBD: adding the address is not supported. Need to find a way to figure 12693## out the ID of the function. 12694## print SCRIPT "disasm \"$tmp\" $address_field\n"; 12695## print SCRIPT "source \"$tmp\" $address_field\n"; 12696#------------------------------------------------------------------------------ 12697 print SCRIPT "disasm \"$tmp\"\n"; 12698 if ($srcfile=~/file/) 12699 { 12700 print SCRIPT "# outfile $outputdir"."$srcfile\n"; 12701 print SCRIPT "outfile $outputdir"."$srcfile\n"; 12702 print SCRIPT "# source \"$tmp\" $address_field\n"; 12703 print SCRIPT "source \"$tmp\"\n"; 12704 } 12705 12706 if ($routine =~ /$find_clone_regex/) 12707 { 12708 my ($clone_routine) = $1.$2.$3.$4; 12709 my ($clone) = $3; 12710 } 12711 } 12712 close SCRIPT; 12713 12714#------------------------------------------------------------------------------ 12715# Remember the number of handled routines depends on the limit setting passed 12716# to er_print together with the sorting order on the metrics, which usually results 12717# in different routines at the top. Thus $RIN below can be greater than the limit. 12718#------------------------------------------------------------------------------ 12719 12720 $RIN = scalar (keys %handled_routines); 12721 12722 if (!$func_limit) 12723 { 12724 $limit_txt = "unlimited"; 12725 } 12726 else 12727 { 12728 $limit_txt = $func_limit - 1; 12729 } 12730 12731 $number_of_metrics = scalar (@sort_fields); 12732 12733 $n_metrics_text = ($number_of_metrics == 1) ? "metric" : "metrics"; 12734 12735 gp_message ("debugXL", $subr_name, "built function list with $RIN functions"); 12736 gp_message ("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt"); 12737 12738# add ELF program header offset 12739 12740 for my $routine_index (sort {$a <=> $b} keys %handled_routines) 12741 { 12742 $routine = $function_info[$routine_index]{"routine"}; 12743 $loadobj = $function_info[$routine_index]{"Load Object"}; 12744 12745 gp_message ("debugXL", $subr_name, "routine = $routine loadobj = $loadobj elf_arch = $elf_arch"); 12746 12747 if ($loadobj ne '') 12748 { 12749 # <Truncated-stack> is associated with <Total>. Its load object is <Total> 12750 if ($loadobj eq "<Total>") 12751 { 12752 next; 12753 } 12754 # Have seen a routine called <Unknown>. Its load object is <Unknown> 12755 if ($loadobj eq "<Unknown>") 12756 { 12757 next; 12758 } 12759############################################################################### 12760## RUUD: The new approach gives a different result. Investigate this. 12761# 12762# Turns out the new code improves the result. The addresses are now correct 12763# and as a result, more ftag's are created later on. 12764############################################################################### 12765 gp_message ("debugXL", $subr_name, "before function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}"); 12766 12767 $function_info[$routine_index]{"addressobj"} += bigint::hex ( 12768 determine_base_va_address ( 12769 $executable_name, 12770 $base_va_executable, 12771 $loadobj, 12772 $routine)); 12773 $addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index; 12774 12775 gp_message ("debugXL", $subr_name, "after function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}"); 12776 gp_message ("debugXL", $subr_name, "after addressobj_index{function_info[$routine_index]{addressobj}} = $addressobj_index{$function_info[$routine_index]{'addressobj'}}"); 12777 } 12778 } 12779 12780#------------------------------------------------------------------------------ 12781# Get the disassembly and source code output. 12782#------------------------------------------------------------------------------ 12783 $gp_listings_cmd = "$GP_DISPLAY_TEXT -limit $func_limit -viewmode machine " . 12784 "-compare off -script $scriptfile $expr_name"; 12785 12786 $gp_display_text_cmd = "$gp_listings_cmd 1> $result_file 2>> $gp_error_file"; 12787 12788 gp_message ("debugXL", $subr_name,"gp_display_text_cmd = $gp_display_text_cmd"); 12789 12790 gp_message ("debug", $subr_name, "calling $GP_DISPLAY_TEXT to produce disassembly and source code output"); 12791 12792 my ($error_code, $cmd_output) = execute_system_cmd ($gp_display_text_cmd); 12793 12794 if ($error_code != 0) 12795 { 12796 $ignore_value = msg_display_text_failure ($gp_display_text_cmd, 12797 $error_code, 12798 $gp_error_file); 12799 gp_message ("abort", $subr_name, "execution terminated"); 12800 } 12801 12802 return (\@function_info, \%function_address_info, \%addressobj_index); 12803 12804} #-- End of subroutine process_function_files 12805 12806#------------------------------------------------------------------------------ 12807# Process the information found in the function overview file passed in. 12808# 12809# Example input: 12810# 12811# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 12812# Functions sorted by metric: Exclusive Total CPU Time 12813# 12814# PC Addr. Name Excl. Excl. CPU Excl. Excl. Excl. Excl. 12815# Total Cycles Instructions Last-Level IPC CPI 12816# CPU sec. sec. Executed Cache Misses 12817# 1:0x00000000 <Total> 3.713 4.256 15396819712 27727992 1.577 0.634 12818# 2:0x000021ae mxv_core 3.532 4.116 14500538992 27527781 1.536 0.651 12819# 2:0x00001f7b init_data 0.070 0.084 64020034 200211 0.333 3.000 12820#------------------------------------------------------------------------------ 12821sub process_function_overview 12822{ 12823 my $subr_name = get_my_name (); 12824 12825 my ($metric_ref, $exp_type_ref, $summary_metrics_ref, $number_of_metrics_ref, 12826 $function_info_ref, $function_view_structure_ref, $overview_file_ref) = @_; 12827 12828 my $metric = ${ $metric_ref }; 12829 my $exp_type = ${ $exp_type_ref }; 12830 my $summary_metrics = ${ $summary_metrics_ref }; 12831 my $number_of_metrics = ${ $number_of_metrics_ref }; 12832 my @function_info = @{ $function_info_ref }; 12833 my %function_view_structure = %{ $function_view_structure_ref }; 12834 my $overview_file = ${ $overview_file_ref }; 12835 12836 my $all_metrics; 12837 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 12838 my $length_of_block; 12839 my $elements_in_name; 12840 my $full_hex_address; 12841 my $header_line; 12842 my $hex_address; 12843 my $html_line; 12844 my $input_line; 12845 my $marker; 12846 my $name_regex; 12847 my $no_of_fields; 12848 my $metrics_length; 12849 my $missing_digits; 12850 my $msg; 12851 my $remaining_part_header; 12852 my $routine; 12853 my $routine_length; 12854 my $scan_header = $FALSE; 12855 my $scan_function_data = $FALSE; 12856 my $string_length; 12857 my $total_header_lines; 12858 12859 my @address_field = (); 12860 my @fields = (); 12861 my @function_data = (); 12862 my @function_names = (); 12863 my @function_view_array = (); 12864 my @function_view_modified = (); 12865 my @header_lines = (); 12866 my @metrics_part = (); 12867 my @metric_values = (); 12868 12869#------------------------------------------------------------------------------ 12870# The regex section. 12871#------------------------------------------------------------------------------ 12872 my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)'; 12873 my $total_marker_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(<Total>)\s+(.*)'; 12874 my $empty_line_regex = '^\s*$'; 12875 my $catch_all_regex = '\s*(.*)'; 12876 my $get_hex_address_regex = '(\d+):0x(\S+)'; 12877 my $get_addr_offset_regex = '^@\d+:'; 12878 my $zero_dot_at_end_regex = '[\w0-9' . $decimal_separator . ']*(0' . $decimal_separator . '$)'; 12879 my $backward_slash_regex = '\/'; 12880 12881 $msg = "enter subroutine " . $subr_name; 12882 gp_message ("debug", $subr_name, $msg); 12883 12884#------------------------------------------------------------------------------ 12885 if (is_file_empty ($overview_file)) 12886 { 12887 gp_message ("assertion", $subr_name, "file $overview_file is empty"); 12888 } 12889 12890 open (FUNC_OVERVIEW, "<", $overview_file) 12891 or die ("$subr_name - unable to open file $overview_file for reading '$!'"); 12892 gp_message ("debug", $subr_name, "opened file $overview_file for reading"); 12893 12894 gp_message ("debug", $subr_name, "processing file for exp_type = $exp_type"); 12895 12896 gp_message ("debugM", $subr_name, "header_name_regex = $header_name_regex"); 12897 gp_message ("debugM", $subr_name, "total_marker_regex = $total_marker_regex"); 12898 gp_message ("debugM", $subr_name, "empty_line_regex = $empty_line_regex"); 12899 gp_message ("debugM", $subr_name, "catch_all_regex = $catch_all_regex"); 12900 gp_message ("debugM", $subr_name, "get_hex_address_regex = $get_hex_address_regex"); 12901 gp_message ("debugM", $subr_name, "get_addr_offset_regex = $get_addr_offset_regex"); 12902 gp_message ("debugM", $subr_name, "zero_dot_at_end_regex = $zero_dot_at_end_regex"); 12903 gp_message ("debugM", $subr_name, "backward_slash_regex = $backward_slash_regex"); 12904 12905#------------------------------------------------------------------------------ 12906# Read the input file into memory. 12907#------------------------------------------------------------------------------ 12908 chomp (@function_data = <FUNC_OVERVIEW>); 12909 gp_message ("debug", $subr_name, "read all of file $overview_file into memory"); 12910 12911#------------------------------------------------------------------------------ 12912# Remove a legacy redundant string, if any. 12913#------------------------------------------------------------------------------ 12914 @function_data = @{ remove_redundant_string (\@function_data)}; 12915 12916#------------------------------------------------------------------------------ 12917# Parse the function view info and store the data. 12918#------------------------------------------------------------------------------ 12919 my $max_header_length = 0; 12920 my $max_metrics_length = 0; 12921 12922#------------------------------------------------------------------------------ 12923# Loop over all the lines. Extract the header, metric values, function names, 12924# and the addresses. 12925# 12926# This is also where the maximum lengths for the header and metric lines are 12927# computed. This is used to get the correct alignment in the HTML output. 12928#------------------------------------------------------------------------------ 12929 for (my $line = 0; $line <= $#function_data; $line++) 12930 { 12931 $input_line = $function_data[$line]; 12932## $input_line =~ s/ -- no functions found//; 12933 12934 gp_message ("debugXL", $subr_name, "input_line = $input_line"); 12935 12936#------------------------------------------------------------------------------ 12937# The table header is assumed to start at the line that has "Name" in it. 12938# The header ends when we see the function name "<Total>". 12939#------------------------------------------------------------------------------ 12940 if ($input_line =~ /$header_name_regex/) 12941 { 12942 $scan_header = $TRUE; 12943 } 12944 elsif ($input_line =~ /$total_marker_regex/) 12945 { 12946 $scan_header = $FALSE; 12947 $scan_function_data = $TRUE; 12948 } 12949 12950 if ($scan_header) 12951 { 12952#------------------------------------------------------------------------------ 12953# This group is only defined for the first line of the header and $4 contains 12954# the remaining part of the line after "Name", without the leading spaces. 12955#------------------------------------------------------------------------------ 12956 if (defined ($4)) 12957 { 12958 $remaining_part_header = $4; 12959 $msg = "remaining_part_header = $remaining_part_header"; 12960 gp_message ("debugXL", $subr_name, $msg); 12961 12962#------------------------------------------------------------------------------ 12963# Determine the maximum length of the header. This needs to be done before 12964# the HTML controls are added. 12965#------------------------------------------------------------------------------ 12966 my $header_length = length ($remaining_part_header); 12967 $max_header_length = max ($max_header_length, $header_length); 12968 12969#------------------------------------------------------------------------------ 12970# TBD Should change this and not yet include html in header_lines 12971#------------------------------------------------------------------------------ 12972 $html_line = "<b>" . $remaining_part_header . "</b>"; 12973 12974 push (@header_lines, $html_line); 12975 12976 gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length"); 12977 gp_message ("debugXL", $subr_name, "html_line = $html_line"); 12978 } 12979#------------------------------------------------------------------------------ 12980# Captures the subsequent header lines. Assume they exist. 12981#------------------------------------------------------------------------------ 12982 elsif ($input_line =~ /$catch_all_regex/) 12983 { 12984 $header_line = $1; 12985 gp_message ("debugXL", $subr_name, "header_line = $header_line"); 12986 12987 my $header_length = length ($header_line); 12988 $max_header_length = max ($max_header_length, $header_length); 12989 12990#------------------------------------------------------------------------------ 12991# TBD Should change this and not yet include html in header_lines 12992#------------------------------------------------------------------------------ 12993 $html_line = "<b>" . $header_line . "</b>"; 12994 12995 push (@header_lines, $html_line); 12996 12997 gp_message ("debugXL", $subr_name, "max_header_length = $max_header_length"); 12998 gp_message ("debugXL", $subr_name, "html_line = $html_line"); 12999 } 13000 } 13001#------------------------------------------------------------------------------ 13002# This is a line with function data. 13003#------------------------------------------------------------------------------ 13004 if ($scan_function_data and (not ($input_line =~ /$empty_line_regex/))) 13005 { 13006 $msg = "detected a line with function data"; 13007 gp_message ("debugXL", $subr_name, $msg); 13008 13009 my ($hex_address_ref, $marker_ref, $reduced_line_ref, 13010 $list_with_metrics_ref) = 13011 split_function_data_line (\$input_line); 13012 13013 $full_hex_address = ${ $hex_address_ref }; 13014 $marker = ${ $marker_ref }; 13015 $routine = ${ $reduced_line_ref }; 13016 $all_metrics = ${ $list_with_metrics_ref }; 13017 13018 $msg = "RESULT full_hex_address = " . $full_hex_address; 13019 $msg .= " -- metric values = " . $all_metrics; 13020 $msg .= " -- marker = " . $marker; 13021 $msg .= " -- function name = " . $routine; 13022 gp_message ("debugXL", $subr_name, $msg); 13023 13024 @fields = split (" ", $input_line); 13025 13026 $no_of_fields = $#fields + 1; 13027 $elements_in_name = $no_of_fields - $number_of_metrics - 1; 13028 13029 $msg = "no_of_fields = " . $no_of_fields; 13030 $msg .= " elements_in_name = " . $elements_in_name; 13031 gp_message ("debugXL", $subr_name, $msg); 13032 13033#------------------------------------------------------------------------------ 13034# In case the last metric is 0. only, we append 3 extra characters that 13035# represent zero. We cannot change the number to 0.000 though because that 13036# has a different interpretation than 0. 13037# In a later phase, the "ZZZ" symbol will be removed again, but for now it 13038# creates consistency in, for example, the length of the metrics part. 13039#------------------------------------------------------------------------------ 13040 if ($all_metrics =~ /$zero_dot_at_end_regex/) 13041 { 13042 if (defined ($1) ) 13043 { 13044#------------------------------------------------------------------------------ 13045# Somewhat overkill, but remove the leading "\" from the decimal separator 13046# in the debug print since it is used for internal purposes only. 13047#------------------------------------------------------------------------------ 13048 my $decimal_point = $decimal_separator; 13049 $decimal_point =~ s/$backward_slash_regex//; 13050 my $txt = "all_metrics = $all_metrics ended with 0"; 13051 $txt .= "$decimal_point ($decimal_separator)"; 13052 gp_message ("debugXL", $subr_name, $txt); 13053 13054 $all_metrics .= "ZZZ"; 13055 } 13056 } 13057 $metrics_length = length ($all_metrics); 13058 $max_metrics_length = max ($max_metrics_length, $metrics_length); 13059 gp_message ("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length"); 13060 13061 $msg = "verify full_hex_address = " . $full_hex_address; 13062 gp_message ("debugXL", $subr_name, $msg); 13063 13064 if ($full_hex_address =~ /$get_hex_address_regex/) 13065 { 13066 $hex_address = "0x" . $2; 13067 } 13068 else 13069 { 13070 $msg = "full_hex_address = $full_hex_address has the wrong format"; 13071 gp_message ("assertion", $subr_name, $msg); 13072 } 13073 13074 push (@address_field, $full_hex_address); 13075 13076 $msg = "pushed full_hex_address = " . $full_hex_address; 13077 gp_message ("debugXL", $subr_name, $msg); 13078 13079 push (@metric_values, $all_metrics); 13080 13081#------------------------------------------------------------------------------ 13082# Record the function name "as is". Below we figure out what the final name 13083# should be in case there are multiple occurrences of the same name. 13084# 13085# The reason to decouple this is to avoid the code gets too complex here. 13086#------------------------------------------------------------------------------ 13087 push (@function_names, $routine); 13088 } 13089 } #-- End of loop over the input lines 13090 13091#------------------------------------------------------------------------------ 13092# Store the maximum lengths for the header and metrics. 13093#------------------------------------------------------------------------------ 13094 gp_message ("debugXL", $subr_name, "final max_header_length = $max_header_length"); 13095 gp_message ("debugXL", $subr_name, "final max_metrics_length = $max_metrics_length"); 13096 13097 $function_view_structure{"max header length"} = $max_header_length; 13098 $function_view_structure{"max metrics length"} = $max_metrics_length; 13099 13100#------------------------------------------------------------------------------ 13101# Determine the final name for the functions and set up the HTML block. 13102#------------------------------------------------------------------------------ 13103 my @final_html_function_block = (); 13104 my @function_index_list = (); 13105 13106#------------------------------------------------------------------------------ 13107# First, an index list is built. If we are to index the functions in order of 13108# appearance in the function overview from 0 to n-1, the value of the array 13109# for index "i" is the index into the large "function_info" structure. This 13110# has the final name, the html function block, etc. 13111#------------------------------------------------------------------------------ 13112 13113 for my $i (keys @address_field) 13114 { 13115 $msg = "address_field[" . $i ."] = " . $address_field[$i]; 13116 gp_message ("debugM", $subr_name, $msg); 13117 } 13118#------------------------------------------------------------------------------ 13119## TBD: Use get_index_function_info??!! 13120#------------------------------------------------------------------------------ 13121 for my $i (keys @function_names) 13122 { 13123#------------------------------------------------------------------------------ 13124# Get the function name and the address from the function overview. The 13125# address is used to differentiate in case a function has multiple occurences. 13126#------------------------------------------------------------------------------ 13127 my $routine = $function_names[$i]; 13128 my $current_address = $address_field[$i]; 13129 13130 my $final_function_name; 13131 my $found_a_match = $FALSE; 13132 my $msg; 13133 my $ref_index; 13134 13135 $msg = "on entry - routine = " . $routine; 13136 $msg .= " current_address = " . $current_address; 13137 gp_message ("debugM", $subr_name, $msg); 13138 13139#------------------------------------------------------------------------------ 13140# Check if there are duplicate entries for this function. If there are, use 13141# the address to find the right match in the function_info structure. 13142#------------------------------------------------------------------------------ 13143 gp_message ("debugXL", $subr_name, "$routine: first check for multiple occurrences"); 13144 if (exists ($g_multi_count_function{$routine})) 13145 { 13146 $msg = "$g_multi_count_function{$routine} exists"; 13147 gp_message ("debugXL", $subr_name, $msg); 13148 $msg = "g_function_occurrences{$routine} = "; 13149 $msg .= $g_function_occurrences{$routine}; 13150 gp_message ("debugXL", $subr_name, $msg); 13151 13152 for my $ref (keys @{ $g_map_function_to_index{$routine} }) 13153 { 13154 my $ref_index = $g_map_function_to_index{$routine}[$ref]; 13155 my $addr_offset = $function_info[$ref_index]{"addressobjtext"}; 13156#------------------------------------------------------------------------------ 13157# The address has the following format: 6:0x0003af50, but we only need the 13158# part after the colon and remove the first part. 13159#------------------------------------------------------------------------------ 13160 $addr_offset =~ s/$get_addr_offset_regex//; 13161 13162 gp_message ("debugXL", $subr_name, "$routine: ref_index = $ref_index"); 13163 gp_message ("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}"); 13164 gp_message ("debugXL", $subr_name, "$routine: addr_offset = $addr_offset"); 13165 13166 if ($addr_offset eq $current_address) 13167#------------------------------------------------------------------------------ 13168# There is a match and we can store the index. 13169#------------------------------------------------------------------------------ 13170 { 13171 $found_a_match = $TRUE; 13172 push (@function_index_list, $ref_index); 13173 last; 13174 } 13175 } 13176 } 13177 else 13178 { 13179#------------------------------------------------------------------------------ 13180# This is the easy case. There is only one index value. We do check if the 13181# array element that contains it, exists. If this is not the case, something 13182# has gone horribly wrong earlier and we need to bail out. 13183#------------------------------------------------------------------------------ 13184 if (defined ($g_map_function_to_index{$routine}[0])) 13185 { 13186 $found_a_match = $TRUE; 13187 $ref_index = $g_map_function_to_index{$routine}[0]; 13188 push (@function_index_list, $ref_index); 13189 my $final_function_name = $function_info[$ref_index]{"routine"}; 13190 gp_message ("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name"); 13191 } 13192 } 13193 if (not $found_a_match) 13194#------------------------------------------------------------------------------ 13195# This should not happen. All we can do is print an error message and stop. 13196#------------------------------------------------------------------------------ 13197 { 13198 $msg = "cannot find the index for $routine: found_a_match = "; 13199 $msg .= ($found_a_match == $TRUE) ? "TRUE" : "FALSE"; 13200 gp_message ("assertion", $subr_name, $msg); 13201 } 13202 } 13203 13204#------------------------------------------------------------------------------ 13205# The loop over all function names has completed and @function_index_list 13206# contains the index values into @function_info for the functions. 13207# 13208# All we now need to do is to retrieve the correct field(s) from the array. 13209#------------------------------------------------------------------------------ 13210 for my $i (keys @function_index_list) 13211 { 13212 my $index_for_function = $function_index_list[$i]; 13213 push (@final_html_function_block, $function_info[$index_for_function]{"html function block"}); 13214 } 13215 for my $i (keys @final_html_function_block) 13216 { 13217 my $txt = "final_html_function_block[$i] = $final_html_function_block[$i]"; 13218 gp_message ("debugXL", $subr_name, $txt); 13219 } 13220 13221#------------------------------------------------------------------------------ 13222# Since the numbers are right aligned, we know that any difference between the 13223# metric line length and the maximum must be caused by the first column. All 13224# we need to do is to prepend spaces in case of a difference. 13225# 13226# While we have the line with the metric values, we also replace ZZZ by 3 13227# spaces. 13228#------------------------------------------------------------------------------ 13229 for my $i (keys @metric_values) 13230 { 13231 if (length ($metric_values[$i]) < $max_metrics_length) 13232 { 13233 my $pad = $max_metrics_length - length ($metric_values[$i]); 13234 my $spaces = ""; 13235 for my $s (1 .. $pad) 13236 { 13237 $spaces .= " "; 13238 } 13239 $metric_values[$i] = $spaces . $metric_values[$i]; 13240 } 13241 $metric_values[$i] =~ s/ZZZ/ /g; 13242 } 13243 13244#------------------------------------------------------------------------------ 13245# Determine the column widths. The start and end index of the words in the 13246# input line are stored in elements 0 and 1 of @word_index_values. 13247# 13248# The assumption made is that the first digit of a metric value on the first 13249# line is left # aligned with the header text. These are the Total values 13250# and other than for some derived metrics, e.g. CPI, should be the largest. 13251# 13252# The positions of the start of the value is what we should then use for the 13253# word "(sort)" to start. 13254# 13255# For example: 13256# 13257# Excl. Excl. CPU Excl. Excl. Excl. Excl. 13258# Total Cycles Instructions Last-Level IPC CPI 13259# CPU sec. sec. Executed Cache Misses 13260# 174.664 179.250 175838403203 1166209617 0.428 2.339 13261#------------------------------------------------------------------------------ 13262 13263 my $foundit_ref; 13264 my $foundit; 13265 my @index_values = (); 13266 my $index_values_ref; 13267 13268#------------------------------------------------------------------------------ 13269# Search for "Excl." in the top row. The metric values are aligned with this 13270# word and we can use it to position "(sort)" in the last header line. 13271# 13272# In @index_values, we store the position(s) of "Excl." in the header line. 13273# If none can be found, an exception is raised because at least one should 13274# be there. 13275# 13276# TBD: Check if this can be done only once. 13277#------------------------------------------------------------------------------ 13278 my $target_keyword = "Excl."; 13279 13280 ($foundit_ref, $index_values_ref) = find_keyword_in_string ( 13281 \$remaining_part_header, 13282 \$target_keyword); 13283 13284 $foundit = ${ $foundit_ref }; 13285 @index_values = @{ $index_values_ref }; 13286 13287 if ($foundit) 13288 { 13289 for my $i (keys @index_values) 13290 { 13291 my $txt = "index_values[$i] = $index_values[$i]"; 13292 gp_message ("debugXL", $subr_name, $txt); 13293 } 13294 } 13295 else 13296 { 13297 $msg = "keyword $target_keyword not found in $remaining_part_header"; 13298 gp_message ("assertion", $subr_name, $msg); 13299 } 13300 13301#------------------------------------------------------------------------------ 13302# Compute the number of spaces we need to add between the "(sort)" strings. 13303# 13304# For example: 13305# 13306# 01234567890123456789 13307# 13308# Excl. Excl. 13309# (sort) (sort) 13310# xxxxxxxx 13311# 13312# The number of spaces required is 14 - 6 = 8. 13313# 13314# The number of spaces to be added is stored in @padding_values. These are 13315# the spaces to be added before the occurrence of "(sort)". This is why the 13316# first padding value is 0. 13317#------------------------------------------------------------------------------ 13318 13319#------------------------------------------------------------------------------ 13320# TBD: This needs to be done only once. 13321#------------------------------------------------------------------------------ 13322 my @padding_values = (); 13323 my $P_previous = 0; 13324 for my $i (keys @index_values) 13325 { 13326 my $L = $index_values[$i]; 13327 my $P = $L + length ("(sort)"); 13328 my $pad_spaces = $L - $P_previous; 13329 13330 push (@padding_values, $pad_spaces); 13331 13332 $P_previous = $P; 13333 } 13334 13335 for my $i (keys @padding_values) 13336 { 13337 my $txt = "padding_values[$i] = $padding_values[$i]"; 13338 gp_message ("debugXL", $subr_name, $txt); 13339 } 13340 13341#------------------------------------------------------------------------------ 13342# Build up the sort line. Mark the current metric and make sure the line is 13343# aligned with the header. 13344#------------------------------------------------------------------------------ 13345 my $sort_string = "(sort)"; 13346 my $length_sort_string = length ($sort_string); 13347 my $sort_line = ""; 13348 my @active_metrics = split (":", $summary_metrics); 13349 for my $i (0 .. $number_of_metrics-1) 13350 { 13351 my $pad = $padding_values[$i]; 13352 my $metric_value = $active_metrics[$i]; 13353 13354 my $spaces = ""; 13355 for my $s (1 .. $pad) 13356 { 13357 $spaces .= " "; 13358 } 13359 13360 gp_message ("debugXL", $subr_name, "i = $i metric_value = $metric_value pad = $pad"); 13361 13362 if ($metric_value eq $exp_type) 13363#------------------------------------------------------------------------------ 13364# The current metric should have a different background color. 13365#------------------------------------------------------------------------------ 13366 { 13367 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . 13368 "." . $metric_value . ".html' style='background-color:" . 13369 $g_html_color_scheme{"background_selected_sort"} . 13370 "\'><b>(sort)</b></a>"; 13371 } 13372 elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric)) 13373#------------------------------------------------------------------------------ 13374# Set the background color for the sort metric in the main function overview. 13375#------------------------------------------------------------------------------ 13376 { 13377 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . 13378 "." . $metric_value . ".html' style='background-color:" . 13379 $g_html_color_scheme{"background_selected_sort"} . 13380 "'><b>(sort)</b></a>"; 13381 } 13382 else 13383#------------------------------------------------------------------------------ 13384# Do not set a specific background for all other metrics. 13385#------------------------------------------------------------------------------ 13386 { 13387 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} . 13388 "." . $metric_value . ".html'>(sort)</a>"; 13389 } 13390 13391#------------------------------------------------------------------------------ 13392# Prepend the spaces to ensure correct alignment with the rest of the header. 13393#------------------------------------------------------------------------------ 13394 $sort_line .= $spaces . $sort_string; 13395 } 13396 13397 push (@header_lines, $sort_line); 13398 13399#------------------------------------------------------------------------------ 13400# Print the final results for the header and metrics. 13401#------------------------------------------------------------------------------ 13402 for my $i (keys @header_lines) 13403 { 13404 gp_message ("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]"); 13405 } 13406 for my $i (keys @metric_values) 13407 { 13408 gp_message ("debugXL", $subr_name, "metric_values[$i] = $metric_values[$i]"); 13409 } 13410 13411#------------------------------------------------------------------------------ 13412# Construct the lines for the function overview. 13413# 13414# TBD: We could eliminate two structures here because metric_values and 13415# final_html_function_block are only copied and the result stored. 13416#------------------------------------------------------------------------------ 13417 for my $i (keys @function_names) 13418 { 13419 push (@metrics_part, $metric_values[$i]); 13420 push (@function_view_array, $final_html_function_block[$i]); 13421 } 13422 13423 for my $i (0 .. $#function_view_array) 13424 { 13425 $msg = "function_view_array[$i] = $function_view_array[$i]"; 13426 gp_message ("debugXL", $subr_name, $msg); 13427 } 13428#------------------------------------------------------------------------------ 13429# Element "function table" contains the array with all the function view data. 13430#------------------------------------------------------------------------------ 13431 $function_view_structure{"header"} = [@header_lines]; 13432 $function_view_structure{"metrics part"} = [@metrics_part]; 13433 $function_view_structure{"function table"} = [@function_view_array]; 13434 13435 $msg = "leave subroutine " . $subr_name; 13436 gp_message ("debug", $subr_name, $msg); 13437 13438 return (\%function_view_structure); 13439 13440} #-- End of subroutine process_function_overview 13441 13442#------------------------------------------------------------------------------ 13443# TBD 13444#------------------------------------------------------------------------------ 13445sub process_metrics 13446{ 13447 my $subr_name = get_my_name (); 13448 13449 my ($input_string, $sort_fields_ref, $metric_description_ref, $ignored_metrics_ref) = @_; 13450 13451 my @sort_fields = @{ $sort_fields_ref }; 13452 my %metric_description = %{ $metric_description_ref }; 13453 my %ignored_metrics = %{ $ignored_metrics_ref }; 13454 13455 my $outputdir = append_forward_slash ($input_string); 13456 my $LANG = $g_locale_settings{"LANG"}; 13457 my $max_len = 0; 13458 my $metric_comment; 13459 13460 my ($imetricn,$outfile); 13461 my ($html_metrics_record,$imetric,$metric); 13462 13463 $html_metrics_record = 13464 "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" . 13465 "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" . 13466 "<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n"; 13467 13468 $outfile = $outputdir . "metrics.html"; 13469 13470 open (METRICSOUT, ">", $outfile) 13471 or die ("$subr_name - unable to open file $outfile for writing - '$!'"); 13472 gp_message ("debug", $subr_name, "opened file $outfile for writing"); 13473 13474 for $metric (@sort_fields) 13475 { 13476 $max_len = max ($max_len, length ($metric)); 13477 gp_message ("debug", $subr_name, "sort_fields: metric = $metric max_len = $max_len"); 13478 } 13479 13480# TBD: Check this 13481# for $imetric (@IMETRICS) 13482 for $imetric (keys %ignored_metrics) 13483 { 13484 $max_len = max ($max_len, length ($imetric)); 13485 gp_message ("debug", $subr_name, "ignored_metrics imetric = $imetric max_len = $max_len"); 13486 } 13487 13488 $max_len++; 13489 13490 gp_message ("debug", $subr_name, "max_len = $max_len"); 13491 13492 $html_metrics_record .= "<p style=\"font-size:14px;color:red\"> Metrics used (".($#sort_fields + 1).")\n</p><p style=\"font-size:14px\">"; 13493 for $metric (@sort_fields) 13494 { 13495 my $description = ${ retrieve_metric_description (\$metric, \%metric_description) }; 13496 gp_message ("debug", $subr_name, "handling metric metric = $metric->$description"); 13497 $html_metrics_record .= " $metric".(' ' x ($max_len - length ($metric)))."$description\n"; 13498 } 13499 13500# $imetricn = scalar (keys %IMETRICS); 13501 $imetricn = scalar (keys %ignored_metrics); 13502 if ($imetricn) 13503 { 13504 $html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">"; 13505# for $imetric (sort keys %IMETRICS){ 13506 for $imetric (sort keys %ignored_metrics) 13507 { 13508 $metric_comment = "(inclusive, exclusive, and percentages)"; 13509 $html_metrics_record .= " $imetric".(' ' x ($max_len - length ($imetric))).$metric_comment."\n"; 13510 gp_message ("debug", $subr_name, "handling metric imetric = $imetric $metric_comment"); 13511 } 13512 } 13513 13514 print METRICSOUT $html_metrics_record; 13515 print METRICSOUT $g_html_credits_line; 13516 close (METRICSOUT); 13517 13518 gp_message ("debug", $subr_name, "closed metrics file $outfile"); 13519 13520 return (0); 13521 13522} #-- End of subroutine process_metrics 13523 13524#------------------------------------------------------------------------------ 13525# TBD 13526#------------------------------------------------------------------------------ 13527sub process_metrics_data 13528{ 13529 my $subr_name = get_my_name (); 13530 13531 my ($outfile1, $outfile2, $ignored_metrics_ref) = @_; 13532 13533 my %ignored_metrics = %{ $ignored_metrics_ref }; 13534 13535 my %metric_value = (); 13536 my %metric_description = (); 13537 my %metric_found = (); 13538 13539 my $user_metrics; 13540 my $system_metrics; 13541 my $wall_metrics; 13542 my $metric_spec; 13543 my $metric_flavor; 13544 my $metric_visibility; 13545 my $metric_name; 13546 my $metric_text; 13547 my $metricdata; 13548 my $metric_line; 13549 my $msg; 13550 13551 my $summary_metrics; 13552 my $detail_metrics; 13553 my $detail_metrics_system; 13554 my $call_metrics; 13555 13556 if ($g_user_settings{"default_metrics"}{"current_value"} eq "off") 13557 { 13558 $msg = "g_user_settings{default_metrics}{current_value} = "; 13559 $msg .= $g_user_settings{"default_metrics"}{"current_value"}; 13560 gp_message ("debug", $subr_name, $msg); 13561 # get metrics 13562 13563 $summary_metrics = ''; 13564 $detail_metrics = ''; 13565 $detail_metrics_system = ''; 13566 $call_metrics = ''; 13567 $user_metrics = 0; 13568 $system_metrics = 0; 13569 $wall_metrics = 0; 13570 13571 my ($last_metric,$metric,$value,$i,$r); 13572 13573 open (METRICTOTALS, "<", $outfile2) 13574 or die ("Unable to open metric value data file $outfile2 for reading - '$!'"); 13575 gp_message ("debug", $subr_name, "opened $outfile2 to parse metric value data"); 13576 13577#------------------------------------------------------------------------------ 13578# Below an example of the file that has just been opened. The lines I marked 13579# with a * has been wrapped by my for readability. This is not the case in the 13580# file, but makes for a really long line. 13581# 13582# Also, the data comes from one PC experiment and two HWC experiments. 13583#------------------------------------------------------------------------------ 13584# <Total> 13585# Exclusive Total CPU Time: 32.473 (100.0%) 13586# Inclusive Total CPU Time: 32.473 (100.0%) 13587# Exclusive CPU Cycles: 23.586 (100.0%) 13588# " count: 47054706905 13589# Inclusive CPU Cycles: 23.586 (100.0%) 13590# " count: 47054706905 13591# Exclusive Instructions Executed: 54417033412 (100.0%) 13592# Inclusive Instructions Executed: 54417033412 (100.0%) 13593# Exclusive Last-Level Cache Misses: 252730685 (100.0%) 13594# Inclusive Last-Level Cache Misses: 252730685 (100.0%) 13595# * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: 13596# * Exclusive Cycles Per Instruction: 13597# * Inclusive Cycles Per Instruction: 13598# * Size: 0 13599# PC Address: 1:0x00000000 13600# Source File: (unknown) 13601# Object File: (unknown) 13602# Load Object: <Total> 13603# Mangled Name: 13604# Aliases: 13605#------------------------------------------------------------------------------ 13606 13607 while (<METRICTOTALS>) 13608 { 13609 $metricdata = $_; chomp ($metricdata); 13610 gp_message ("debug", $subr_name, "file metrictotals: $metricdata"); 13611 13612#------------------------------------------------------------------------------ 13613# Ignoring whitespace, search for any line with a ":" in it, followed by 13614# a number with or without a dot. So, an integer or floating-point number. 13615#------------------------------------------------------------------------------ 13616 if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/) 13617 { 13618 gp_message ("debug", $subr_name, " candidate => $metricdata"); 13619 $metric = $1; 13620 $value = $2; 13621 if ( ($metric eq "PC Address") or ($metric eq "Size")) 13622 { 13623 gp_message ("debug", $subr_name, " skipped => $metric $value"); 13624 next; 13625 } 13626 gp_message ("debug", $subr_name, " proceed => $metric $value"); 13627 if ($metric eq '" count') 13628#------------------------------------------------------------------------------ 13629# Hardware counter experiments have this info. Note that this line is not the 13630# first one to be encountered, so $last_metric has been defined already. 13631#------------------------------------------------------------------------------ 13632 { 13633 $metric = $last_metric." Count"; # we presume ....... 13634 gp_message ("debug", $subr_name, "last_metric = $last_metric metric = $metric"); 13635 } 13636 $i=index ($metricdata,":"); 13637 $r=rindex ($metricdata,":"); 13638 gp_message ("debug", $subr_name, "metricdata = $metricdata => i = $i r = $r"); 13639 if ($i == $r) 13640 { 13641 if ($value > 0) # Not interested in metrics contributing zero 13642 { 13643 $metric_value{$metric} = $value; 13644 gp_message ("debug", $subr_name, "archived metric_value{$metric} = $metric_value{$metric}"); 13645 # e.g. $metric_value{Exclusive Total Thread Time} = 302.562 13646 # e.g. $metric_value{Exclusive Instructions Executed} = 2415126222484 13647 } 13648 } 13649 else 13650#------------------------------------------------------------------------------ 13651# TBD This code deals with an old bug and may be removed. 13652#------------------------------------------------------------------------------ 13653 { # er_print bug - e.g. 13654# Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: Exclusive Cycles Per Instruction: Inclusive Cycles Per Instruction: Exclusive OpenMP Work Time: 162.284 (100.0%) 13655 gp_message ("debug", $subr_name, "metrictotals odd line:->$metricdata<-"); 13656 $r=rindex ($metricdata,":",$r-1); 13657 if ($r == -1) 13658 { # ignore 13659 gp_message ("debug", $subr_name, "metrictotals odd line ignored<-"); 13660 $last_metric = "foo"; 13661 next; 13662 } 13663 my ($good_part)=substr ($metricdata,$r+1); 13664 if ($good_part =~ /\s*(.*):\s+(\d+\.*\d*)/) 13665 { 13666 $metric = $1; 13667 $value = $2; 13668 if ($value>0) # Not interested in metrics contributing zero 13669 { 13670 $metric_value{$metric} = $value; 13671 $msg = "metrictotals odd line rescued '$metric'=$value"; 13672 gp_message ("debug", $subr_name, $msg); 13673 } 13674 } 13675 } 13676#------------------------------------------------------------------------------ 13677# Preserve the current metric. 13678#------------------------------------------------------------------------------ 13679 $last_metric = $metric; 13680 } 13681 } 13682 close (METRICTOTALS); 13683 } 13684 13685 if (scalar (keys %metric_value) == 0) 13686#------------------------------------------------------------------------------ 13687# If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we 13688# blow up later. 13689# 13690# TBD: See if this can be handled differently. 13691#------------------------------------------------------------------------------ 13692 { 13693 $metric_value{"Exclusive Total CPU Time"} = 0; 13694 gp_message ("debug", $subr_name, "no metrics found and a stub was added"); 13695 } 13696 13697 for my $metric (sort keys %metric_value) 13698 { 13699 gp_message ("debug", $subr_name, "Stored metric_value{$metric} = $metric_value{$metric}"); 13700 } 13701 13702 gp_message ("debug", $subr_name, "proceed to process file $outfile1"); 13703 13704#------------------------------------------------------------------------------ 13705# Open and process the metrics file. 13706#------------------------------------------------------------------------------ 13707 open (METRICS, "<", $outfile1) 13708 or die ("Unable to open metrics file $outfile1: '$!'"); 13709 gp_message ("debug", $subr_name, "opened file $outfile1 for reading"); 13710 13711#------------------------------------------------------------------------------ 13712# Parse the file. This is a typical example: 13713# 13714# Exp Sel Total 13715# === === ===== 13716# 1 all 2 13717# 2 all 1 13718# 3 all 2 13719# Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name 13720# Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu ) 13721# Available metrics: 13722# Exclusive Total CPU Time: e.%totalcpu 13723# Inclusive Total CPU Time: i.%totalcpu 13724# Exclusive CPU Cycles: e.+%cycles 13725# Inclusive CPU Cycles: i.+%cycles 13726# Exclusive Instructions Executed: e+%insts 13727# Inclusive Instructions Executed: i+%insts 13728# Exclusive Last-Level Cache Misses: e+%llm 13729# Inclusive Last-Level Cache Misses: i+%llm 13730# Exclusive Instructions Per Cycle: e+IPC 13731# Inclusive Instructions Per Cycle: i+IPC 13732# Exclusive Cycles Per Instruction: e+CPI 13733# Inclusive Cycles Per Instruction: i+CPI 13734# Size: size 13735# PC Address: address 13736# Name: name 13737#------------------------------------------------------------------------------ 13738 while (<METRICS>) 13739 { 13740 $metric_line = $_; 13741 chomp ($metric_line); 13742 13743 gp_message ("debug", $subr_name, "processing line $metric_line"); 13744#------------------------------------------------------------------------------ 13745# The original regex has bugs because the line should not be allowed to start 13746# with a ":". So this is wrong: 13747# if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/)) 13748# 13749# This is better: 13750# if (($metric =~ /\s*(.+):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/)) 13751# 13752# In general, this regex has some potential issues and has been replaced by 13753# the one shown below. 13754# 13755# We select a line that does not start with "Current" and aside from whitespace 13756# starts with anything (although it should be a string with words only), 13757# followed by whitespace and either an "e" or "i". This is called the "flavor" 13758# and is followed by a visibility marker (.,+,%, or !) and a metric name. 13759#------------------------------------------------------------------------------ 13760# Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){ 13761 13762 ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) = 13763 extract_metric_specifics ($metric_line); 13764 13765# if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/)) 13766 if ($metric_spec eq "skipped") 13767 { 13768 gp_message ("debug", $subr_name, "skipped line: $metric_line"); 13769 } 13770 else 13771 { 13772 gp_message ("debug", $subr_name, "line of interest: $metric_line"); 13773 13774 $metric_found{$metric_spec} = 1; 13775 13776 if ($g_user_settings{"ignore_metrics"}{"defined"}) 13777 { 13778 gp_message ("debug", $subr_name, "check for $metric_spec"); 13779 if (exists ($ignored_metrics{$metric_name})) 13780 { 13781 gp_message ("debug", $subr_name, "user asked to ignore metric $metric_name"); 13782 next; 13783 } 13784 } 13785 13786#------------------------------------------------------------------------------ 13787# This metric is not on the ignored list and qualifies, so store it. 13788#------------------------------------------------------------------------------ 13789 $metric_description{$metric_spec} = $metric_text; 13790 13791# TBD: add for other visibilities too, like + 13792 gp_message ("debug", $subr_name, "stored $metric_description{$metric_spec} = $metric_description{$metric_spec}"); 13793 13794 if ($metric_flavor ne "e") 13795 { 13796 gp_message ("debug", $subr_name, "metric $metric_spec is ignored"); 13797 } 13798 else 13799#------------------------------------------------------------------------------ 13800# Only the exclusive metrics are shown. 13801#------------------------------------------------------------------------------ 13802 { 13803 gp_message ("debug", $subr_name, "metric $metric_spec ($metric_text) is considered"); 13804 13805 if ($metric_spec =~ /user/) 13806 { 13807 $user_metrics = $TRUE; 13808 gp_message ("debug", $subr_name, "m: user_metrics set to TRUE"); 13809 } 13810 elsif ($metric_spec =~ /system/) 13811 { 13812 $system_metrics = $TRUE; 13813 gp_message ("debug", $subr_name, "m: system_metrics set to TRUE"); 13814 } 13815 elsif ($metric_spec =~ /wall/) 13816 { 13817 $wall_metrics = $TRUE; 13818 gp_message ("debug", $subr_name, "m: wall_metrics set to TRUE"); 13819 } 13820#------------------------------------------------------------------------------ 13821# TBD I don't see why these need to be skipped. Also, should be totalcpu. 13822#------------------------------------------------------------------------------ 13823 elsif (($metric_spec =~ /^e\.total$/) or ($metric_spec =~/^e\.total_cpu$/)) 13824 { 13825 # skip total thread time and total CPU time 13826 gp_message ("debug", $subr_name, "m: skip above"); 13827 } 13828 elsif (defined ($metric_value{$metric_text})) 13829 { 13830 gp_message ("debug", $subr_name, "Total attributed to this metric metric_value{$metric_text} = $metric_value{$metric_text}"); 13831 if ($summary_metrics ne '') 13832 { 13833 $summary_metrics = $summary_metrics.':'.$metric_spec; 13834 gp_message ("debug", $subr_name, "updated summary_metrics = $summary_metrics - 1"); 13835 if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/) 13836 { 13837 $detail_metrics = $detail_metrics.':'.$metric_spec; 13838 gp_message ("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1"); 13839 $detail_metrics_system = $detail_metrics_system.':'.$metric_spec; 13840 gp_message ("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1"); 13841 } 13842 else 13843 { 13844 gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); 13845 } 13846 } 13847 else 13848 { 13849 $summary_metrics = $metric_spec; 13850 gp_message ("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2"); 13851 if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/) 13852 { 13853 $detail_metrics = $metric_spec; 13854 gp_message ("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2"); 13855 $detail_metrics_system = $metric_spec; 13856 gp_message ("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2"); 13857 } 13858 else 13859 { 13860 gp_message ("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system"); 13861 } 13862 } 13863 gp_message ("debug", $subr_name, " metric $metric_spec added"); 13864 } 13865 else 13866 { 13867 gp_message ("debug", $subr_name, "m: no want above metric was a 0 total"); 13868 } 13869 } 13870 } 13871 } 13872 13873 close METRICS; 13874 13875 if ($wall_metrics > 0) 13876 { 13877 gp_message ("debug", $subr_name,"m:wall_metrics set adding to summary_metrics"); 13878 $summary_metrics = "e.wall:".$summary_metrics; 13879 gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 3"); 13880 } 13881 13882 if ($system_metrics > 0) 13883 { 13884 gp_message ("debug", $subr_name,"m:system_metrics set adding to summary_metrics,call_metrics and detail_metrics_system"); 13885 $summary_metrics = "e.system:".$summary_metrics; 13886 $call_metrics = "i.system:".$call_metrics; 13887 $detail_metrics_system ='e.system:'.$detail_metrics_system; 13888 13889 gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 4"); 13890 gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics"); 13891 gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 3"); 13892 } 13893 13894 13895#------------------------------------------------------------------------------ 13896# TBD: e.user and i.user do not always exist!! 13897#------------------------------------------------------------------------------ 13898 13899 if ($user_metrics > 0) 13900 { 13901 gp_message ("debug", $subr_name,"m:user_metrics set adding to summary_metrics,detail_metrics,detail_metrics_system and call_metrics"); 13902# Ruud if (!exists ($IMETRICS{"i.user"})){ 13903 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) 13904 { 13905 $summary_metrics = "e.user:".$summary_metrics; 13906 } 13907 else 13908 { 13909 $summary_metrics = "e.user:i.user:".$summary_metrics; 13910 } 13911 $detail_metrics = "e.user:".$detail_metrics; 13912 $detail_metrics_system = "e.user:".$detail_metrics_system; 13913 13914 gp_message ("debug", $subr_name,"m:summary_metrics=$summary_metrics - 5"); 13915 gp_message ("debug", $subr_name,"m:detail_metrics=$detail_metrics - 3"); 13916 gp_message ("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 4"); 13917 13918 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"})) 13919 { 13920 $call_metrics = "a.user:".$call_metrics; 13921 } 13922 else 13923 { 13924 $call_metrics = "a.user:i.user:".$call_metrics; 13925 } 13926 gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 2"); 13927 } 13928 13929 if ($call_metrics eq "") 13930 { 13931 $call_metrics = $detail_metrics; 13932 13933 gp_message ("debug", $subr_name,"m:call_metrics is not set, setting it to detail_metrics "); 13934 gp_message ("debug", $subr_name,"m:call_metrics=$call_metrics - 3"); 13935 } 13936 13937 for my $metric (sort keys %ignored_metrics) 13938 { 13939 if ($ignored_metrics{$metric}) 13940 { 13941 gp_message ("debug", $subr_name, "active metric, but ignored: $metric"); 13942 } 13943 13944 } 13945 13946 return (\%metric_value, \%metric_description, \%metric_found, $user_metrics, $system_metrics, $wall_metrics, 13947 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics); 13948 13949} #-- End of subroutine process_metrics_data 13950 13951#------------------------------------------------------------------------------ 13952# Process source lines that are not part of the target function. 13953# 13954# Generate straightforward HTML, but define an anchor based on the source line 13955# number in the list. 13956#------------------------------------------------------------------------------ 13957sub process_non_target_source 13958{ 13959 my $subr_name = get_my_name (); 13960 13961 my ($start_scan, $end_scan, 13962 $src_times_regex, $function_regex, $number_of_metrics, 13963 $file_contents_ref, $modified_html_ref) = @_; 13964 13965 my @file_contents = @{ $file_contents_ref }; 13966 my @modified_html = @{ $modified_html_ref }; 13967 my $colour_code_line = $FALSE; 13968 my $input_line; 13969 my $line_id; 13970 my $modified_line; 13971 13972#------------------------------------------------------------------------------ 13973# Main loop to parse all of the source code and take action as needed. 13974#------------------------------------------------------------------------------ 13975 for (my $line_no=$start_scan; $line_no <= $end_scan; $line_no++) 13976 { 13977 $input_line = $file_contents[$line_no]; 13978 13979#------------------------------------------------------------------------------ 13980# Generate straightforward HTML, but define an anchor based on the source line 13981# number in the list. 13982#------------------------------------------------------------------------------ 13983 $line_id = extract_source_line_number ($src_times_regex, 13984 $function_regex, 13985 $number_of_metrics, 13986 $input_line); 13987 13988 if ($input_line =~ /$function_regex/) 13989 { 13990 $colour_code_line = $TRUE; 13991 } 13992 13993#------------------------------------------------------------------------------ 13994# We need to replace the "<" symbol in the code by "<". 13995#------------------------------------------------------------------------------ 13996 $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 13997 13998#------------------------------------------------------------------------------ 13999# Add an id. 14000#------------------------------------------------------------------------------ 14001 $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; 14002 14003 my $coloured_line; 14004 if ($colour_code_line) 14005 { 14006 my $boldface = $TRUE; 14007 $coloured_line = color_string ( 14008 $input_line, 14009 $boldface, 14010 $g_html_color_scheme{"non_target_function_name"}); 14011 $colour_code_line = $FALSE; 14012 $modified_line .= "$coloured_line"; 14013 } 14014 else 14015 { 14016 $modified_line .= "$input_line"; 14017 } 14018 gp_message ("debugXL", $subr_name, " $line_no : modified_line = $modified_line"); 14019 push (@modified_html, $modified_line); 14020 } 14021 14022 return (\@modified_html); 14023 14024} #-- End of subroutine process_non_target_source 14025 14026#------------------------------------------------------------------------------ 14027# This function scans the configuration file and adapts the internal settings 14028# accordingly. 14029# 14030# Errors are stored during the parsing and processing phase. They are printed 14031# at the end and sorted by line number. 14032# 14033# 14034# TBD: Does not yet use the warnings/error system. This needs to be fixed. 14035#------------------------------------------------------------------------------ 14036sub process_rc_file 14037{ 14038 my $subr_name = get_my_name (); 14039 14040 my ($rc_file_name, $rc_file_paths_ref) = @_; 14041 14042#------------------------------------------------------------------------------ 14043# Local structures. 14044#------------------------------------------------------------------------------ 14045# Stores the values extracted from the config file: 14046 my %rc_settings_user = (); 14047 my %error_and_warning_msgs = (); 14048 my @rc_file_paths = (); 14049 14050 my @split_line; 14051 my @my_fields; 14052 14053 my $msg; 14054 my $first_part; 14055 my $line; 14056 my $line_number; 14057 my $no_of_arguments; 14058 my $number_of_fields; 14059 my $number_of_paths; 14060 my $parse_errors; #-- Count the number of errors 14061 my $parse_warnings; #-- Count the number of errors 14062 14063 my $rc_config_file; 14064 my $rc_file_found; 14065 my $rc_keyword; 14066 my $rc_value; 14067 14068 @rc_file_paths = @{$rc_file_paths_ref}; 14069 $number_of_paths = scalar (@rc_file_paths); 14070 14071 if ($number_of_paths == 0) 14072#------------------------------------------------------------------------------ 14073# This should not happen, but is a good safety net to add. 14074#------------------------------------------------------------------------------ 14075 { 14076 my $msg = "search path list is empty"; 14077 gp_message ("assertion", $subr_name, $msg); 14078 } 14079 14080#------------------------------------------------------------------------------ 14081# Check for the presence of a configuration file. 14082#------------------------------------------------------------------------------ 14083 $msg = "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths"; 14084 gp_message ("debug", $subr_name, $msg); 14085 14086 $rc_file_found = $FALSE; 14087 for my $path_name (@rc_file_paths) 14088 { 14089 $rc_config_file = $path_name . "/" . $rc_file_name; 14090 $msg = "looking for configuration file " . $rc_config_file; 14091 gp_message ("debug", $subr_name, $msg); 14092 if (-f $rc_config_file) 14093 { 14094 $msg = "found configuration file " . $rc_config_file; 14095 gp_message ("debug", $subr_name, $msg); 14096 $rc_file_found = $TRUE; 14097 last; 14098 } 14099 } 14100 14101 if (not $rc_file_found) 14102#------------------------------------------------------------------------------ 14103# There is no configuration file and we can skip this subroutine. 14104#------------------------------------------------------------------------------ 14105 { 14106 $msg = "configuration file $rc_file_name not found"; 14107 gp_message ("verbose", $subr_name, $msg); 14108 return (0); 14109 } 14110 else 14111 { 14112 $msg = "unable to open file $rc_config_file for reading:"; 14113 open (GP_DISPLAY_HTML_RC, "<", "$rc_config_file") 14114 or die ($subr_name . " - " . $msg . " " . $!); 14115#------------------------------------------------------------------------------ 14116# The configuration file has been opened for reading. 14117#------------------------------------------------------------------------------ 14118 $msg = "file $rc_config_file has been opened for reading"; 14119 gp_message ("debug", $subr_name, $msg); 14120 } 14121 14122 $msg = "found configuration file $rc_config_file"; 14123 gp_message ("verbose", $subr_name, $msg); 14124 $msg = "processing configuration file " . $rc_config_file; 14125 gp_message ("debug", $subr_name, $msg); 14126 14127#------------------------------------------------------------------------------ 14128# Here we scan the configuration file for the settings. 14129# 14130# A setting consists of a keyword, optionally followed by a value. It is 14131# optional because not all keywords may require a value. 14132# 14133# At the end of this block, all keyword/value pairs are stored in a hash. 14134# 14135# We do not yet check for the validity of these pairs. This is done next. 14136# 14137# The original code had this all integrated, but it made the code very 14138# complex with deeply nested if-statements. The flow was also hard to follow. 14139#------------------------------------------------------------------------------ 14140 $parse_errors = 0; 14141 $parse_warnings = 0; 14142 $line_number = 0; 14143 while (my $line = <GP_DISPLAY_HTML_RC>) 14144 { 14145 chomp ($line); 14146 $line_number++; 14147 14148 gp_message ("debug", $subr_name, "read input line = $line"); 14149 14150#------------------------------------------------------------------------------ 14151# Ignore a line with whitespace only 14152#------------------------------------------------------------------------------ 14153 if ($line =~ /^\s*$/) 14154 { 14155 gp_message ("debug", $subr_name, "ignored a line with whitespace"); 14156 next; 14157 } 14158 14159#------------------------------------------------------------------------------ 14160# Ignore a comment line, defined by starting with a "#", possibly prepended by 14161# whitespace. 14162#------------------------------------------------------------------------------ 14163 if ($line =~ /^\s*\#/) 14164 { 14165 gp_message ("debug", $subr_name, "ignored a full comment line"); 14166 next; 14167 } 14168 14169#------------------------------------------------------------------------------ 14170# Split the input line using the "#" symbol as a separator. We have already 14171# handled the case of an isolated comment line, so there may only be an 14172# embedded comment. 14173# 14174# Regardless of this, we are only interested in the first part. 14175#------------------------------------------------------------------------------ 14176 @split_line = split ("#", $line); 14177 14178 for my $i (@split_line) 14179 { 14180 gp_message ("debug", $subr_name, "elements after split of line: $i"); 14181 } 14182 14183 $first_part = $split_line[0]; 14184 gp_message ("debug", $subr_name, "relevant part = $first_part"); 14185 14186 if ($first_part =~ /[&\^\*\@\$]+/) 14187#------------------------------------------------------------------------------ 14188# The &, ^, *, @ and $ symbols should not occur. If they do, we flag an error 14189# an fetch the next line. 14190#------------------------------------------------------------------------------ 14191 { 14192 $parse_errors++; 14193 $msg = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line"; 14194 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; 14195 next; 14196 } 14197 else 14198#------------------------------------------------------------------------------ 14199# Split the first part on whitespace and verify the number of fields to be 14200# valid. Although we currently only have keywords with a value, a keyword 14201# without value is supported to. 14202# 14203# If the number of fields is valid, the keyword and value are stored. In case 14204# of a single field, the value is assigned a special string. 14205# 14206# Although this situation should not occur, we do abort if something unexpected 14207# is encountered here. 14208#------------------------------------------------------------------------------ 14209 { 14210 @my_fields = split (/\s/, $split_line[0]); 14211 14212 $number_of_fields = scalar (@my_fields); 14213 $msg = "number of fields = " . $number_of_fields; 14214 gp_message ("debug", $subr_name, $msg); 14215 } 14216 14217 if ($number_of_fields ge 3) 14218#------------------------------------------------------------------------------ 14219# This is not supported. 14220#------------------------------------------------------------------------------ 14221 { 14222 $parse_errors++; 14223 $msg = "more than 2 fields found: $first_part"; 14224 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; 14225 next; 14226 } 14227 elsif ($number_of_fields eq 2) 14228 { 14229 $rc_keyword = $my_fields[0]; 14230 $rc_value = $my_fields[1]; 14231 } 14232 elsif ($number_of_fields eq 1) 14233 { 14234 $rc_keyword = $my_fields[0]; 14235 $rc_value = "the_field_is_empty"; 14236 } 14237 else 14238 { 14239 $msg = "[line $line_number] $rc_config_file -"; 14240 $msg .= " number of fields = $number_of_fields"; 14241 gp_message ("assertion", $subr_name, $msg); 14242 } 14243 14244#------------------------------------------------------------------------------ 14245# Store the keyword, value and line number. 14246#------------------------------------------------------------------------------ 14247 if (exists ($rc_settings_user{$rc_keyword})) 14248 { 14249 $parse_warnings++; 14250 my $prev_value = $rc_settings_user{$rc_keyword}{"value"}; 14251 my $prev_line_number = $rc_settings_user{$rc_keyword}{"line_no"}; 14252 if ($rc_value ne $prev_value) 14253 { 14254 $msg = "option $rc_keyword previously set at line"; 14255 $msg .= " $prev_line_number: new value '$rc_value'"; 14256 $msg .= " ' overrides '$prev_value'"; 14257 } 14258 else 14259 { 14260 $msg = "option $rc_keyword previously set to the same value"; 14261 $msg .= " at line $prev_line_number"; 14262 } 14263 $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $msg; 14264 } 14265 $rc_settings_user{$rc_keyword}{"value"} = $rc_value; 14266 $rc_settings_user{$rc_keyword}{"line_no"} = $line_number; 14267 14268 gp_message ("debug", $subr_name, "stored keyword = $rc_keyword"); 14269 gp_message ("debug", $subr_name, "stored value = $rc_value"); 14270 gp_message ("debug", $subr_name, "stored line number = $line_number"); 14271 } 14272 14273#------------------------------------------------------------------------------ 14274# Completed the parsing of the configuration file. It can be closed. 14275#------------------------------------------------------------------------------ 14276 close (GP_DISPLAY_HTML_RC); 14277 14278#------------------------------------------------------------------------------ 14279# Print the raw input as just collected from the configuration file. 14280#------------------------------------------------------------------------------ 14281 gp_message ("debug", $subr_name, "contents of %rc_settings_user:"); 14282 for my $keyword (keys %rc_settings_user) 14283 { 14284 my $key_value = $rc_settings_user{$keyword}{"value"}; 14285 $msg = "keyword = " . $keyword . " value = " . $key_value; 14286 gp_message ("debug", $subr_name, $msg); 14287 } 14288 14289 for my $rc_keyword (keys %g_user_settings) 14290 { 14291 for my $fields (keys %{ $g_user_settings{$rc_keyword} }) 14292 { 14293 $msg = "before config file: $rc_keyword $fields ="; 14294 $msg .= " " . $g_user_settings{$rc_keyword}{$fields}; 14295 gp_message ("debug", $subr_name, $msg); 14296 } 14297 } 14298 14299#------------------------------------------------------------------------------ 14300# We are almost done. Check for all keywords found whether they are valid. 14301# Also verify that the corresponding value is valid. 14302# 14303# Update the g_user_settings table if everything is okay. 14304#------------------------------------------------------------------------------ 14305 14306 for my $rc_keyword (keys %rc_settings_user) 14307 { 14308 my $rc_value = $rc_settings_user{$rc_keyword}{"value"}; 14309 14310 if (exists ( $g_user_settings{$rc_keyword})) 14311 { 14312 14313#------------------------------------------------------------------------------ 14314# This is a supported keyword. There are two more things left to do: 14315# - Check how many values it requires (currently exactly one is supported) 14316# - Is the value a valid number or string? 14317#------------------------------------------------------------------------------ 14318 $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"}; 14319 14320 if ($no_of_arguments eq 1) 14321 { 14322 my $input_value = $rc_value; 14323 if ($input_value ne "the_field_is_empty") 14324# 14325#------------------------------------------------------------------------------ 14326# So far, so good. We only need to check if the value is valid for the keyword. 14327#------------------------------------------------------------------------------ 14328 { 14329 my $data_type = $g_user_settings{$rc_keyword}{"data_type"}; 14330 my $valid_input = 14331 verify_if_input_is_valid ($input_value, $data_type); 14332#------------------------------------------------------------------------------ 14333# Check if the value is valid. 14334#------------------------------------------------------------------------------ 14335 if ($valid_input) 14336 { 14337 $g_user_settings{$rc_keyword}{"current_value"} = 14338 $rc_value; 14339 $g_user_settings{$rc_keyword}{"defined"} = $TRUE; 14340 } 14341 else 14342 { 14343 $parse_errors++; 14344 $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; 14345 $msg = "input value '$input_value' for keyword"; 14346 $msg .= " $rc_keyword is not valid"; 14347 $error_and_warning_msgs{"error"}{$line_number}{"message"} 14348 = $msg; 14349 next; 14350 } 14351 } 14352 else 14353#------------------------------------------------------------------------------ 14354# This keyword requires a value, but none has been found. 14355#------------------------------------------------------------------------------ 14356 { 14357 $parse_errors++; 14358 $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; 14359 $msg = "missing value for keyword '$rc_keyword'"; 14360 $error_and_warning_msgs{"error"}{$line_number}{"message"} 14361 = $msg; 14362 next; 14363 } 14364 } 14365 elsif ($no_of_arguments eq 0) 14366#------------------------------------------------------------------------------ 14367# Currently a theoretical scenario since all commands require a value, but in 14368# case this is no longer true, we need to at least flag the fact the user set 14369# this command. 14370#------------------------------------------------------------------------------ 14371 { 14372 $g_user_settings{$rc_keyword}{"defined"} = $TRUE; 14373 } 14374 else 14375#------------------------------------------------------------------------------ 14376# The code is not prepared for the situation one command has multiple values, 14377# but this situation should never occur. Still it won't hurt to add a check. 14378#------------------------------------------------------------------------------ 14379 { 14380 my $msg = "cannot handle $no_of_arguments in the input"; 14381 gp_message ("assertion", $subr_name, $msg); 14382 } 14383 } 14384 else 14385#------------------------------------------------------------------------------ 14386# A non-valid keyword is found. This is flagged as an error. 14387#------------------------------------------------------------------------------ 14388 { 14389 $parse_errors++; 14390 $line_number = $rc_settings_user{$rc_keyword}{"line_no"}; 14391 $msg = "keyword $rc_keyword is not supported"; 14392 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg; 14393 } 14394 } 14395 for my $rc_keyword (keys %g_user_settings) 14396 { 14397 for my $fields (keys %{ $g_user_settings{$rc_keyword} }) 14398 { 14399 $msg = "after config file: $rc_keyword $fields ="; 14400 $msg .= " " . $g_user_settings{$rc_keyword}{$fields}; 14401 gp_message ("debug", $subr_name, $msg); 14402 } 14403 } 14404 print_table_user_settings ("debug", "upon the return from $subr_name"); 14405 14406 if ( ($parse_errors == 0) and ($parse_warnings == 0) ) 14407 { 14408 $msg = "successfully parsed and processed the configuration file"; 14409 gp_message ("verbose", $subr_name, $msg); 14410 } 14411 else 14412 { 14413 if ($parse_errors > 0) 14414 { 14415 my $plural_or_single = ($parse_errors > 1) ? "errors" : "error"; 14416 $msg = $g_error_keyword . "found $parse_errors fatal"; 14417 $msg .= " " . $plural_or_single . " in the configuration file:"; 14418 gp_message ("debug", $subr_name, $msg); 14419#------------------------------------------------------------------------------ 14420# Sort the hash keys, the line numbers, alphabetically and print the 14421# corresponding error messages. 14422#------------------------------------------------------------------------------ 14423 for my $line_no (sort {$a <=> $b} 14424 (keys %{ $error_and_warning_msgs{"error"} })) 14425 { 14426 $msg = $g_error_keyword . "[line $line_no] in file"; 14427 $msg .= $rc_config_file . " - "; 14428 $msg .= $error_and_warning_msgs{"error"}{$line_no}{"message"}; 14429 gp_message ("debug", $subr_name, $msg); 14430 } 14431 } 14432 14433 if (not $g_quiet) 14434 { 14435 if ($parse_warnings > 0) 14436 { 14437 $msg = $g_warn_keyword . " found $parse_warnings warnings in"; 14438 $msg .= " the configuration file:"; 14439 gp_message ("debug", $subr_name, $msg); 14440 for my $line_no (sort {$a <=> $b} 14441 (keys %{ $error_and_warning_msgs{"warning"} })) 14442 { 14443 $msg = $g_warn_keyword; 14444 $msg .= " [line $line_no] in file $rc_config_file - "; 14445 $msg .= $error_and_warning_msgs{"warning"}{$line_no}{"message"}; 14446 gp_message ("debug", $subr_name, $msg); 14447 } 14448 } 14449 } 14450 } 14451 14452 return ($parse_errors); 14453 14454} #-- End of subroutine process_rc_file 14455 14456#------------------------------------------------------------------------------ 14457# Generate the annotated html file for the source listing. 14458#------------------------------------------------------------------------------ 14459sub process_source 14460{ 14461 my $subr_name = get_my_name (); 14462 14463 my ($number_of_metrics, $function_info_ref, 14464 $outputdir, $input_filename) = @_; 14465 14466 my @function_info = @{ $function_info_ref }; 14467 14468#------------------------------------------------------------------------------ 14469# The regex section 14470#------------------------------------------------------------------------------ 14471 my $end_src1_header_regex = '(^\s+)(\d+)\.\s+(.*)'; 14472 my $end_src2_header_regex = '(^\s+)(<Function: )(.*)>'; 14473 my $function_regex = '^(\s*)<Function:\s(.*)>'; 14474 my $function2_regex = '^(\s*)<Function:\s(.*)>'; 14475 my $src_regex = '(\s*)(\d+)\.(.*)'; 14476 my $txt_ext_regex = '\.txt$'; 14477 my $src_filename_id_regex = '^file\.(\d+)\.src\.txt$'; 14478 my $integer_only_regex = '\d+'; 14479#------------------------------------------------------------------------------ 14480# Computed dynamically below. 14481# TBD: Try to move this up. 14482#------------------------------------------------------------------------------ 14483 my $src_times_regex; 14484 my $hot_lines_regex; 14485 my $metric_regex; 14486 my $metric_extra_regex; 14487 14488 my @components = (); 14489 my @fields_in_line = (); 14490 my @file_contents = (); 14491 my @hot_source_lines = (); 14492 my @max_metric_values = (); 14493 my @modified_html = (); 14494 my @transposed_hot_lines = (); 14495 14496 my $colour_coded_line; 14497 my $colour_coded_line_ref; 14498 my $line_id; 14499 my $ignore_value; 14500 my $func_name_in_src_file; 14501 my $html_new_line = "<br>"; 14502 my $input_line; 14503 my $metric_values; 14504 my $modified_html_ref; 14505 my $modified_line; 14506 my $is_empty; 14507 my $start_all_source; 14508 my $start_target_source; 14509 my $end_target_source; 14510 my $output_line; 14511 my $hot_line; 14512 my $src_line_no; 14513 my $src_code_line; 14514 14515 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 14516 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; 14517 14518 my $file_title; 14519 my $found_target; 14520 my $html_dis_record; 14521 my $html_end; 14522 my $html_header; 14523 my $html_home; 14524 my $rounded_percentage; 14525 my $start_tracking; 14526 my $threshold_line; 14527 14528 my $base; 14529 my $boldface; 14530 my $msg; 14531 my $routine; 14532 14533 my $LANG = $g_locale_settings{"LANG"}; 14534 my $the_title = set_title ($function_info_ref, $input_filename, 14535 "process source"); 14536 my $outfile = $input_filename . ".html"; 14537 14538#------------------------------------------------------------------------------ 14539# Remove the .txt from file.<n>.src.txt 14540#------------------------------------------------------------------------------ 14541 my $html_output_file = $input_filename; 14542 $html_output_file =~ s/$txt_ext_regex/.html/; 14543 14544 gp_message ("debug", $subr_name, "input_filename = $input_filename"); 14545 gp_message ("debug", $subr_name, "the_title = $the_title"); 14546 14547 $file_title = $the_title; 14548 $html_header = ${ create_html_header (\$file_title) }; 14549 $html_home = ${ generate_home_link ("right") }; 14550 14551 push (@modified_html, $html_header); 14552 push (@modified_html, $html_home); 14553 push (@modified_html, "<pre>"); 14554 14555#------------------------------------------------------------------------------ 14556# Open the html file used for the output. 14557#------------------------------------------------------------------------------ 14558 open (NEW_HTML, ">", $html_output_file) 14559 or die ("$subr_name - unable to open file $html_output_file for writing: '$!'"); 14560 gp_message ("debug", $subr_name , "opened file $html_output_file for writing"); 14561 14562 $base = get_basename ($input_filename); 14563 14564 gp_message ("debug", $subr_name, "base = $base"); 14565 14566 if ($base =~ /$src_filename_id_regex/) 14567 { 14568 my $file_id = $1; 14569 if (defined ($function_info[$file_id]{"routine"})) 14570 { 14571 $routine = $function_info[$file_id]{"routine"}; 14572 14573 gp_message ("debugXL", $subr_name, "target routine = $routine"); 14574 } 14575 else 14576 { 14577 my $msg = "cannot retrieve routine name for file_id = $file_id"; 14578 gp_message ("assertion", $subr_name, $msg); 14579 } 14580 } 14581 14582#------------------------------------------------------------------------------ 14583# Check if the input file is empty. If so, generate a short text in the html 14584# file and return. Otherwise open the file and read the contents. 14585#------------------------------------------------------------------------------ 14586 $is_empty = is_file_empty ($input_filename); 14587 14588 if ($is_empty) 14589 { 14590#------------------------------------------------------------------------------ 14591# The input file is empty. Write a diagnostic message in the html file and exit. 14592#------------------------------------------------------------------------------ 14593 gp_message ("debug", $subr_name ,"file $input_filename is empty"); 14594 14595 my $comment = "No source listing generated by $tool_name - " . 14596 "file $input_filename is empty"; 14597 my $error_file = $outputdir . "gp-listings.err"; 14598 14599 my $html_empty_file_ref = html_text_empty_file (\$comment, \$error_file); 14600 my @html_empty_file = @{ $html_empty_file_ref }; 14601 14602 print NEW_HTML "$_\n" for @html_empty_file; 14603 14604 close NEW_HTML; 14605 14606 return (0); 14607 } 14608 else 14609#------------------------------------------------------------------------------ 14610# Open the input file with the source code 14611#------------------------------------------------------------------------------ 14612 { 14613 open (SRC_LISTING, "<", $input_filename) 14614 or die ("$subr_name - unable to open file $input_filename for reading: '$!'"); 14615 gp_message ("debug", $subr_name, "opened file $input_filename for reading"); 14616 } 14617 14618#------------------------------------------------------------------------------ 14619# Generate the regex for the metrics. This depends on the number of metrics. 14620#------------------------------------------------------------------------------ 14621 gp_message ("debug", $subr_name, "decimal_separator = $decimal_separator<--"); 14622 14623 $metric_regex = ''; 14624 $metric_extra_regex = ''; 14625 for my $metric_used (1 .. $number_of_metrics) 14626 { 14627 $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+'; 14628 } 14629 $metric_extra_regex = $metric_regex . '(\d+' . $decimal_separator . ')'; 14630 14631 $hot_lines_regex = '^(#{2})\s+'; 14632 $hot_lines_regex .= '('.$metric_regex.')'; 14633 $hot_lines_regex .= '([0-9?]+)\.\s+(.*)'; 14634 14635 $src_times_regex = '^(#{2}|\s{2})\s+'; 14636 $src_times_regex .= '('.$metric_extra_regex.')'; 14637 $src_times_regex .= '(.*)'; 14638 14639 gp_message ("debugXL", $subr_name, "metric_regex = $metric_regex"); 14640 gp_message ("debugXL", $subr_name, "hot_lines_regex = $hot_lines_regex"); 14641 gp_message ("debugXL", $subr_name, "src_times_regex = $src_times_regex"); 14642 gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); 14643 14644 gp_message ("debugXL", $subr_name, "end_src1_header_regex = $end_src1_header_regex"); 14645 gp_message ("debugXL", $subr_name, "end_src2_header_regex = $end_src2_header_regex"); 14646 gp_message ("debugXL", $subr_name, "function_regex = $function_regex"); 14647 gp_message ("debugXL", $subr_name, "function2_regex = $function2_regex"); 14648 gp_message ("debugXL", $subr_name, "src_regex = $src_regex"); 14649 14650#------------------------------------------------------------------------------ 14651# Read the file into memory. 14652#------------------------------------------------------------------------------ 14653 chomp (@file_contents = <SRC_LISTING>); 14654 14655#------------------------------------------------------------------------------ 14656# Identify the header lines. Make the minimal assumptions. 14657# 14658# In both cases, the first line after the header has whitespace. This is 14659# followed by either one of the following: 14660# 14661# - <line_no>. 14662# - <Function: 14663# 14664# These are the characteristics we use below. 14665#------------------------------------------------------------------------------ 14666 for (my $line_number=0; $line_number <= $#file_contents; $line_number++) 14667 { 14668 $input_line = $file_contents[$line_number]; 14669 14670#------------------------------------------------------------------------------ 14671# We found the first source code line. Bail out. 14672#------------------------------------------------------------------------------ 14673 if (($input_line =~ /$end_src1_header_regex/) or 14674 ($input_line =~ /$end_src2_header_regex/)) 14675 { 14676 gp_message ("debugXL", $subr_name, "header time is over - hit source line"); 14677 gp_message ("debugXL", $subr_name, "line_number = $line_number"); 14678 gp_message ("debugXL", $subr_name, "input_line = $input_line"); 14679 last; 14680 } 14681 else 14682#------------------------------------------------------------------------------ 14683# Store the header lines in the html structure. 14684#------------------------------------------------------------------------------ 14685 { 14686 $modified_line = "<i>" . $input_line . "</i>"; 14687 push (@modified_html, $modified_line); 14688 } 14689 } 14690#------------------------------------------------------------------------------ 14691# We know the source code starts at this index value: 14692#------------------------------------------------------------------------------ 14693 $start_all_source = scalar (@modified_html); 14694 gp_message ("debugXL", $subr_name, "source starts at start_all_source = $start_all_source"); 14695 14696#------------------------------------------------------------------------------ 14697# Scan the file to identify where the target source starts and ends. 14698#------------------------------------------------------------------------------ 14699 gp_message ("debugXL", $subr_name, "search for target function $routine"); 14700 $start_tracking = $FALSE; 14701 $found_target = $FALSE; 14702 for (my $line_number=0; $line_number <= $#file_contents; $line_number++) 14703 { 14704 $input_line = $file_contents[$line_number]; 14705 14706 gp_message ("debugXL", $subr_name, "[$line_number] $input_line"); 14707 14708 if ($input_line =~ /$function_regex/) 14709 { 14710 if (defined ($1) and defined ($2)) 14711 { 14712 $func_name_in_src_file = $2; 14713 my $msg = "found a function - name = $func_name_in_src_file"; 14714 gp_message ("debugXL", $subr_name, $msg); 14715 14716 if ($start_tracking) 14717 { 14718 $start_tracking = $FALSE; 14719 $end_target_source = $line_number - 1; 14720 my $msg = "end_target_source = $end_target_source"; 14721 gp_message ("debugXL", $subr_name, $msg); 14722 last; 14723 } 14724 14725 if ($func_name_in_src_file eq $routine) 14726 { 14727 $found_target = $TRUE; 14728 $start_tracking = $TRUE; 14729 $start_target_source = $line_number; 14730 14731 gp_message ("debugXL", $subr_name, "found target function $routine"); 14732 gp_message ("debugXL", $subr_name, "function_name = $2 routine = $routine"); 14733 gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); 14734 gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); 14735 } 14736 } 14737 else 14738 { 14739 my $msg = "parsing line $input_line"; 14740 gp_message ("assertion", $subr_name, $msg); 14741 } 14742 } 14743 } 14744 14745#------------------------------------------------------------------------------ 14746# This is not supposed to happen, but it is not a fatal error either. The 14747# hyperlinks related to this function will not work, so a warning is issued. 14748# A message is issued both in debug mode, and as a warning. 14749#------------------------------------------------------------------------------ 14750 if (not $found_target) 14751 { 14752 my $msg; 14753 14754 $msg = "target function $routine not found in $base - " . 14755 "links to source code involving this function will not work"; 14756 gp_message ("debug", $subr_name, $msg); 14757 gp_message ("warning", $subr_name, $msg); 14758 $g_total_warning_count++; 14759 14760 return ($found_target); 14761 } 14762 14763#------------------------------------------------------------------------------ 14764# Catch the line number of the last function. 14765#------------------------------------------------------------------------------ 14766 if ($start_tracking) 14767 { 14768 $end_target_source = $#file_contents; 14769 } 14770 gp_message ("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking"); 14771 gp_message ("debugXL", $subr_name, "start_target_source = $start_target_source"); 14772 gp_message ("debugXL", $subr_name, "end_target_source = $end_target_source"); 14773 14774#------------------------------------------------------------------------------ 14775# We now have the index range for the function of interest and will parse it. 14776# Since we already handled the first line with the function marker, we start 14777# with the line following. 14778#------------------------------------------------------------------------------ 14779 14780#------------------------------------------------------------------------------ 14781# Find the hot source lines and store them. 14782#------------------------------------------------------------------------------ 14783 gp_message ("debugXL", $subr_name, "determine the maximum metric values"); 14784 for (my $line_number=$start_target_source+1; $line_number <= $end_target_source; $line_number++) 14785 { 14786 $input_line = $file_contents[$line_number]; 14787 gp_message ("debugXL", $subr_name, " $line_number : check input_line = $input_line"); 14788 14789 if ( $input_line =~ /$hot_lines_regex/ ) 14790 { 14791 gp_message ("debugXL", $subr_name, " $line_number : found a hot line"); 14792#------------------------------------------------------------------------------ 14793# We found a hot line and the metric fields are stored in $2. We turn this 14794# string into an array and add it as a row to hot_source_lines. 14795#------------------------------------------------------------------------------ 14796 $hot_line = $1; 14797 $metric_values = $2; 14798 14799 gp_message ("debugXL", $subr_name, "hot_line = $hot_line"); 14800 gp_message ("debugXL", $subr_name, "metric_values = $metric_values"); 14801 14802 my @metrics = split (" ", $metric_values); 14803 push (@hot_source_lines, [@metrics]); 14804 } 14805 gp_message ("debugXL", $subr_name, " $line_number : completed check for hot line"); 14806 } 14807 14808#------------------------------------------------------------------------------ 14809# Transpose the array with the hot lines. This means each row has all the 14810# values for a metrict and it makes it easier to determine the maximum values. 14811#------------------------------------------------------------------------------ 14812 for my $row (keys @hot_source_lines) 14813 { 14814 my $msg = "row[" . $row . "] ="; 14815 for my $col (keys @{$hot_source_lines[$row]}) 14816 { 14817 $msg .= " $hot_source_lines[$row][$col]"; 14818 $transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col]; 14819 } 14820 } 14821 14822#------------------------------------------------------------------------------ 14823# Print the maximum metric values found. Each row contains the data for a 14824# different metric. 14825#------------------------------------------------------------------------------ 14826 for my $row (keys @transposed_hot_lines) 14827 { 14828 my $msg = "row[" . $row . "] ="; 14829 for my $col (keys @{$transposed_hot_lines[$row]}) 14830 { 14831 $msg .= " $transposed_hot_lines[$row][$col]"; 14832 } 14833 gp_message ("debugXL", $subr_name, "hot lines = $msg"); 14834 } 14835 14836#------------------------------------------------------------------------------ 14837# Determine the maximum value for each metric. 14838#------------------------------------------------------------------------------ 14839 for my $row (keys @transposed_hot_lines) 14840 { 14841 my $max_val = 0; 14842 for my $col (keys @{$transposed_hot_lines[$row]}) 14843 { 14844 $max_val = max ($transposed_hot_lines[$row][$col], $max_val); 14845 } 14846#------------------------------------------------------------------------------ 14847# Convert to a floating point number. 14848#------------------------------------------------------------------------------ 14849 if ($max_val =~ /$integer_only_regex/) 14850 { 14851 $max_val = sprintf ("%f", $max_val); 14852 } 14853 push (@max_metric_values, $max_val); 14854 } 14855 14856 for my $metric (keys @max_metric_values) 14857 { 14858 my $msg = "$input_filename max_metric_values[$metric] = " . 14859 $max_metric_values[$metric]; 14860 gp_message ("debugXL", $subr_name, $msg); 14861 } 14862 14863#------------------------------------------------------------------------------ 14864# Process those functions that are not the current target. 14865#------------------------------------------------------------------------------ 14866 $modified_html_ref = process_non_target_source ($start_all_source, 14867 $start_target_source-1, 14868 $src_times_regex, 14869 $function_regex, 14870 $number_of_metrics, 14871 \@file_contents, 14872 \@modified_html); 14873 @modified_html = @{ $modified_html_ref }; 14874 14875#------------------------------------------------------------------------------ 14876# This is the core part to process the information for the target function. 14877#------------------------------------------------------------------------------ 14878 gp_message ("debugXL", $subr_name, "parse and process the target source"); 14879 $modified_html_ref = process_target_source ($start_target_source, 14880 $end_target_source, 14881 $routine, 14882 \@max_metric_values, 14883 $src_times_regex, 14884 $function2_regex, 14885 $number_of_metrics, 14886 \@file_contents, 14887 \@modified_html); 14888 @modified_html = @{ $modified_html_ref }; 14889 14890 if ($end_target_source < $#file_contents) 14891 { 14892 $modified_html_ref = process_non_target_source ($end_target_source+1, 14893 $#file_contents, 14894 $src_times_regex, 14895 $function_regex, 14896 $number_of_metrics, 14897 \@file_contents, 14898 \@modified_html); 14899 @modified_html = @{ $modified_html_ref }; 14900 } 14901 14902 gp_message ("debug", $subr_name, "completed reading source"); 14903 14904#------------------------------------------------------------------------------ 14905# Add an extra line with diagnostics. 14906# 14907# TBD: The same is done in generate_dis_html but should be done only once. 14908#------------------------------------------------------------------------------ 14909 if ($hp_value > 0) 14910 { 14911 my $rounded_percentage = sprintf ("%.1f", $hp_value); 14912 $threshold_line = "<i>The setting for the highlight percentage"; 14913 $threshold_line .= " (--highlight-percentage) option:"; 14914 $threshold_line .= " " . $rounded_percentage . " (%)</i>"; 14915 } 14916 else 14917 { 14918 $threshold_line = "<i>The highlight percentage feature has not been"; 14919 $threshold_line .= " enabled</i>"; 14920 } 14921 14922 $html_home = ${ generate_home_link ("left") }; 14923 $html_end = ${ terminate_html_document () }; 14924 14925 push (@modified_html, "</pre>"); 14926 push (@modified_html, "<br>"); 14927 push (@modified_html, $threshold_line); 14928 push (@modified_html, $html_home); 14929 push (@modified_html, "<br>"); 14930 push (@modified_html, $g_html_credits_line); 14931 push (@modified_html, $html_end); 14932 14933 for my $i (0 .. $#modified_html) 14934 { 14935 gp_message ("debugXL", $subr_name, "[$i] -> $modified_html[$i]"); 14936 } 14937 14938#------------------------------------------------------------------------------ 14939# Write the generated HTML text to file. 14940#------------------------------------------------------------------------------ 14941 for my $i (0 .. $#modified_html) 14942 { 14943 print NEW_HTML "$modified_html[$i]" . "\n"; 14944 } 14945 close (NEW_HTML); 14946 close (SRC_LISTING); 14947 14948 return ($found_target); 14949 14950} #-- End of subroutine process_source 14951 14952#------------------------------------------------------------------------------ 14953# Process the source lines for the target function. 14954#------------------------------------------------------------------------------ 14955sub process_target_source 14956{ 14957 my $subr_name = get_my_name (); 14958 14959 my ($start_scan, $end_scan, $target_function, $max_metric_values_ref, 14960 $src_times_regex, $function2_regex, $number_of_metrics, 14961 $file_contents_ref, $modified_html_ref) = @_; 14962 14963 my @file_contents = @{ $file_contents_ref }; 14964 my @modified_html = @{ $modified_html_ref }; 14965 my @max_metric_values = @{ $max_metric_values_ref }; 14966 14967 my @components = (); 14968 14969 my $colour_coded_line; 14970 my $colour_coded_line_ref; 14971 my $hot_line; 14972 my $input_line; 14973 my $line_id; 14974 my $modified_line; 14975 my $metric_values; 14976 my $src_code_line; 14977 my $src_line_no; 14978 14979 gp_message ("debug", $subr_name, "parse and process the core loop"); 14980 14981 for (my $line_number=$start_scan; $line_number <= $end_scan; $line_number++) 14982 { 14983 $input_line = $file_contents[$line_number]; 14984 14985#------------------------------------------------------------------------------ 14986# We need to replace the "<" symbol in the code by "<". 14987#------------------------------------------------------------------------------ 14988 $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g; 14989 14990 $line_id = extract_source_line_number ($src_times_regex, 14991 $function2_regex, 14992 $number_of_metrics, 14993 $input_line); 14994 14995 gp_message ("debug", $subr_name, "line_number = $line_number : input_line = $input_line line_id = $line_id"); 14996 14997 if ($input_line =~ /$function2_regex/) 14998#------------------------------------------------------------------------------ 14999# Found the function marker. 15000#------------------------------------------------------------------------------ 15001 { 15002 if (defined ($1) and defined ($2)) 15003 { 15004 my $func_name_in_file = $2; 15005 my $spaces = $1; 15006 my $boldface = $TRUE; 15007 gp_message ("debug", $subr_name, "function_name = $2"); 15008 my $function_line = "<Function: " . $func_name_in_file . ">"; 15009 my $color_function_name = color_string ( 15010 $function_line, 15011 $boldface, 15012 $g_html_color_scheme{"target_function_name"}); 15013 my $ftag; 15014 if (exists ($g_function_tag_id{$target_function})) 15015 { 15016 $ftag = $g_function_tag_id{$target_function}; 15017 gp_message ("debug", $subr_name, "target_function = $target_function ftag = $ftag"); 15018 } 15019 else 15020 { 15021 my $msg = "no ftag found for $target_function"; 15022 gp_message ("assertion", $subr_name, $msg); 15023 } 15024 $modified_line = "<a id=\"" . $ftag . "\"></a>"; 15025 $modified_line .= $spaces . "<i>" . $color_function_name . "</i>"; 15026 } 15027 } 15028 elsif ($input_line =~ /$src_times_regex/) 15029#------------------------------------------------------------------------------ 15030# This is a line with metric values. 15031#------------------------------------------------------------------------------ 15032 { 15033 gp_message ("debug", $subr_name, "input line has metrics"); 15034 15035 $hot_line = $1; 15036 $metric_values = $2; 15037 $src_line_no = $3; 15038 $src_code_line = $4; 15039 15040 gp_message ("debug", $subr_name, "hot_line = $hot_line"); 15041 gp_message ("debug", $subr_name, "metric_values = $metric_values"); 15042 gp_message ("debug", $subr_name, "src_line_no = $src_line_no"); 15043 gp_message ("debug", $subr_name, "src_code_line = $src_code_line"); 15044 15045 if ($hot_line eq "##") 15046#------------------------------------------------------------------------------ 15047# Highlight the most expensive line. 15048#------------------------------------------------------------------------------ 15049 { 15050 @components = split (" ", $input_line, 1+$number_of_metrics+2); 15051 $modified_line = set_background_color_string ( 15052 $input_line, 15053 $g_html_color_scheme{"background_color_hot"}); 15054 } 15055 else 15056 { 15057#------------------------------------------------------------------------------ 15058# Highlight those lines close enough to the most expensive line. 15059#------------------------------------------------------------------------------ 15060 @components = split (" ", $input_line, $number_of_metrics + 2); 15061 for my $i (0 .. $number_of_metrics-1) 15062 { 15063 gp_message ("debugXL", $subr_name, "$line_number : time check components[$i] = $components[$i]"); 15064 } 15065 15066 $colour_coded_line_ref = check_metric_values ($metric_values, \@max_metric_values); 15067 15068 $colour_coded_line = $ {$colour_coded_line_ref}; 15069 if ($colour_coded_line) 15070 { 15071 gp_message ("debugXL", $subr_name, "$line_number : change background colour modified_line = $modified_line"); 15072 $modified_line = set_background_color_string ($input_line, $g_html_color_scheme{"background_color_lukewarm"}); 15073 } 15074 else 15075 { 15076 $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; 15077 $modified_line .= "$input_line"; 15078 } 15079 } 15080 } 15081 else 15082#------------------------------------------------------------------------------ 15083# This is a regular line that is not modified. 15084#------------------------------------------------------------------------------ 15085 { 15086#------------------------------------------------------------------------------ 15087# Add an id. 15088#------------------------------------------------------------------------------ 15089 gp_message ("debug", $subr_name, "$line_number : input line is a regular line"); 15090 $modified_line = "<a id=\"line_" . $line_id . "\"></a>"; 15091 $modified_line .= "$input_line"; 15092 } 15093 gp_message ("debug", $subr_name, "$line_number : mod = $modified_line"); 15094 push (@modified_html, $modified_line); 15095 } 15096 15097 return (\@modified_html); 15098 15099} #-- End of subroutine process_target_source 15100 15101#------------------------------------------------------------------------------ 15102# Process the options. Set associated variables and check the options for 15103# correctness. For example, detect if conflicting options have been set. 15104#------------------------------------------------------------------------------ 15105sub process_user_options 15106{ 15107 my $subr_name = get_my_name (); 15108 15109 my ($exp_dir_list_ref) = @_; 15110 15111 my @exp_dir_list = @{ $exp_dir_list_ref }; 15112 15113 my %ignored_metrics = (); 15114 15115 my $abs_path_dir; 15116 my @candidate_ignored_metrics = (); 15117 my $error_code; 15118 my $hp_value; 15119 my $msg; 15120 15121 my $outputdir; 15122 15123 my $target_cmd; 15124 my $rm_output_msg; 15125 my $mkdir_output_msg; 15126 my $time_percentage_multiplier; 15127 my $process_all_functions; 15128 15129#------------------------------------------------------------------------------ 15130# The -o and -O options are mutually exclusive. 15131#------------------------------------------------------------------------------ 15132 my $define_new_output_dir = $g_user_settings{"output"}{"defined"}; 15133 my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"}; 15134 my $dir_o_option = $g_user_settings{"output"}{"current_value"}; 15135 my $dir_O_option = $g_user_settings{"overwrite"}{"current_value"}; 15136 15137 if ($define_new_output_dir and $overwrite_output_dir) 15138 { 15139 $msg = "the -o/--output and -O/--overwrite options are both set, " . 15140 "but are mutually exclusive"; 15141 gp_message ("error", $subr_name, $msg); 15142 15143 $msg = "(setting for -o = $dir_o_option, " . 15144 "setting for -O = $dir_O_option)"; 15145 gp_message ("error", $subr_name, $msg); 15146 15147 $g_total_error_count++; 15148 } 15149 15150#------------------------------------------------------------------------------ 15151# The warnings option is deprecated. Print a warning to this extent and point 15152# to the --nowarnings option. 15153#------------------------------------------------------------------------------ 15154#------------------------------------------------------------------------------ 15155# Handle the situation that both or one of the highlight-percentage and hp 15156# options are set. 15157#------------------------------------------------------------------------------ 15158 if ($g_user_settings{"warnings"}{"defined"}) 15159 { 15160 $msg = "<br>" . "the --warnings option has been deprecated and"; 15161 $msg .= " will be ignored"; 15162 gp_message ("warning", $subr_name, $msg); 15163 15164 if ($g_user_settings{"nowarnings"}{"defined"}) 15165 { 15166 $msg = "since the --nowarnings option is also used, warnings"; 15167 $msg .= " are disabled"; 15168 gp_message ("warning", $subr_name, $msg); 15169 } 15170 else 15171 { 15172 $msg = "by default, warnings are enabled and can be disabled with"; 15173 gp_message ("warning", $subr_name, $msg); 15174 $msg = " the --nowarnings option"; 15175 gp_message ("warning", $subr_name, $msg); 15176 } 15177 $g_total_warning_count++; 15178 } 15179 15180#------------------------------------------------------------------------------ 15181# In case both the --highlight-percentage and -hp option are set, issue a 15182# warning and continue with the --highlight-percentage value. 15183#------------------------------------------------------------------------------ 15184 if ($g_user_settings{"hp"}{"defined"}) 15185 { 15186 $msg = "<br>" . "the -hp option has been deprecated and"; 15187 $msg .= " will be ignored"; 15188 gp_message ("warning", $subr_name, $msg); 15189 15190 if ($g_user_settings{"highlight_percentage"}{"defined"}) 15191 { 15192 $msg = "since the --highlight-percentage option is also used,"; 15193 $msg .= " the value of "; 15194 $msg .= $g_user_settings{"highlight_percentage"}{"current_value"}; 15195 $msg .= " will be applied"; 15196 gp_message ("warning", $subr_name, $msg); 15197 } 15198 else 15199 { 15200#------------------------------------------------------------------------------ 15201# If only the -hp option is set, we use it, because we do not want to break 15202# compatibility (yet) and force the user to change the option. 15203#------------------------------------------------------------------------------ 15204 15205## FUTURE $msg = "instead, the default setting of " 15206## FUTURE $msg .= $g_user_settings{"highlight_percentage"}{"current_value"}; 15207## FUTURE $msg .= " for the --highlight-percentage will be used"; 15208## FUTURE gp_message ("warning", $subr_name, $msg); 15209 15210## FUTURE $msg = "please use this option to set the highlighting value"; 15211## FUTURE gp_message ("warning", $subr_name, $msg); 15212 15213 $g_user_settings{"highlight_percentage"}{"current_value"} = 15214 $g_user_settings{"hp"}{"current_value"}; 15215 15216 $g_user_settings{"highlight_percentage"}{"defined"} = $TRUE; 15217 15218 $msg = "for now, the value of " . 15219 $g_user_settings{"hp"}{"current_value"} . 15220 " for the -hp option is used, but please change the" . 15221 " option to --highlight-percentage"; 15222 gp_message ("warning", $subr_name, $msg); 15223 } 15224 15225 $g_total_warning_count++; 15226 } 15227 15228#------------------------------------------------------------------------------ 15229# Regardless of the use of the -hp option, we continue with the value for 15230# highlight-percentage. Some more checks are carried out now. 15231#------------------------------------------------------------------------------ 15232 15233#------------------------------------------------------------------------------ 15234# This value should be in the interval [0,100]. 15235# the number to be positive, but the limits have not been checked yet. 15236#------------------------------------------------------------------------------ 15237 $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"}; 15238 15239 if (($hp_value < 0) or ($hp_value > 100)) 15240 { 15241 $msg = "the value for the highlight percentage is set to $hp_value,"; 15242 $msg .= " but must be in the range [0, 100]"; 15243 gp_message ("error", $subr_name, $msg); 15244 15245 $g_total_error_count++; 15246 } 15247 elsif ($hp_value == 0.0) 15248#------------------------------------------------------------------------------ 15249# A value of zero is interpreted to mean that highlighting should be disabled. 15250# To make the checks for this later on easier, set it to an integer value of 0. 15251#------------------------------------------------------------------------------ 15252 { 15253 $g_user_settings{"highlight_percentage"}{"current_value"} = 0; 15254 15255 $msg = "reset the highlight percentage value from 0.0 to"; 15256 $msg .= " " . $g_user_settings{"highlight_percentage"}{"current_value"}; 15257 gp_message ("debug", $subr_name, $msg); 15258 } 15259 15260#------------------------------------------------------------------------------ 15261# The value for TP should be in the interval (0,100]. We already enforced 15262# the number to be positive, but the limits have not been checked yet. 15263#------------------------------------------------------------------------------ 15264 my $tp_value = $g_user_settings{"threshold_percentage"}{"current_value"}; 15265 15266 if (($tp_value < 0) or ($tp_value > 100)) 15267 { 15268 $msg = "the value for the total percentage is set to $tp_value,"; 15269 $msg .= " but must be in the range (0, 100]"; 15270 gp_message ("error", $subr_name, $msg); 15271 15272 $g_total_error_count++; 15273 } 15274 else 15275 { 15276 $time_percentage_multiplier = $tp_value/100.0; 15277 15278# Ruud if (($TIME_PERCENTAGE_MULTIPLIER*100.) >= 100.) 15279 15280 if ($tp_value == 100) 15281 { 15282 $process_all_functions = $TRUE; # ensure that all routines are handled 15283 } 15284 else 15285 { 15286 $process_all_functions = $FALSE; 15287 } 15288 15289 $msg = "value of time_percentage_multiplier = " . 15290 $time_percentage_multiplier; 15291 gp_message ("debugM", $subr_name, $msg); 15292 $msg = "value of process_all_functions = " . 15293 ($process_all_functions ? "TRUE" : "FALSE"); 15294 gp_message ("debugM", $subr_name, $msg); 15295 } 15296 15297#------------------------------------------------------------------------------ 15298# If imetrics has been set, split the list into the individual metrics that 15299# need to be excluded. The associated hash called $ignore_metrics has the 15300# to be excluded metrics as an index. The value of $TRUE assigned does not 15301# really matter. 15302#------------------------------------------------------------------------------ 15303 if ($g_user_settings{"ignore_metrics"}{"defined"}) 15304 { 15305 @candidate_ignored_metrics = 15306 split (":", $g_user_settings{"ignore_metrics"}{"current_value"}); 15307 } 15308 for my $metric (@candidate_ignored_metrics) 15309 { 15310# TBD: bug? $ignored_metrics{$metric} = $FALSE; 15311 $ignored_metrics{$metric} = $TRUE; 15312 } 15313 for my $metric (keys %ignored_metrics) 15314 { 15315 my $msg = "ignored_metrics{$metric} = $ignored_metrics{$metric}"; 15316 gp_message ("debugM", $subr_name, $msg); 15317 } 15318 15319#------------------------------------------------------------------------------ 15320# Check if the experiment directories exist and if they do, add the absolute 15321# path. This is easier in the remainder. 15322#------------------------------------------------------------------------------ 15323 for my $i (0 .. $#exp_dir_list) 15324 { 15325 if (-d $exp_dir_list[$i]) 15326 { 15327 $abs_path_dir = Cwd::abs_path ($exp_dir_list[$i]); 15328 $exp_dir_list[$i] = $abs_path_dir; 15329 15330 $msg = "directory $exp_dir_list[$i] exists"; 15331 gp_message ("debugM", $subr_name, $msg); 15332 } 15333 } 15334 15335 return (\%ignored_metrics, $outputdir, $time_percentage_multiplier, 15336 $process_all_functions, \@exp_dir_list); 15337 15338} #-- End of subroutine process_user_options 15339 15340#------------------------------------------------------------------------------ 15341# This function addresses a legacy issue. 15342# 15343# In binutils 2.40, the "gprofng display text" tool may add a string in the 15344# function overviews. This did not add any value and was disruptive to the 15345# output. It has been removed in 2.41, but in order to support the older 15346# versions of gprofng, the string is removed before the data is processed. 15347# 15348# Note: the double space in "-- no" is not a typo in this code! 15349#------------------------------------------------------------------------------ 15350sub remove_redundant_string 15351{ 15352 my $subr_name = get_my_name (); 15353 15354 my ($target_array_ref) = @_; 15355 15356 my @target_array = @{ $target_array_ref }; 15357 15358 my $msg; 15359 my $redundant_string = " -- no functions found"; 15360 15361 for (my $line = 0; $line <= $#target_array; $line++) 15362 { 15363 $target_array[$line] =~ s/$redundant_string//; 15364 } 15365 15366 $msg = "removed any occurrence of " . $redundant_string; 15367 gp_message ("debugM", $subr_name, $msg); 15368 15369 return (\@target_array); 15370 15371} #-- End of subroutine remove_redundant_string 15372 15373#------------------------------------------------------------------------------ 15374# This is a hopefully temporary routine to disable/ignore selected user 15375# settings. As the functionality expands, this list will get shorter. 15376#------------------------------------------------------------------------------ 15377sub reset_selected_settings 15378{ 15379 my $subr_name = get_my_name (); 15380 15381 $g_locale_settings{"decimal_separator"} = "\\."; 15382 $g_locale_settings{"convert_to_dot"} = $FALSE; 15383 $g_user_settings{func_limit}{current_value} = 1000000; 15384 15385 gp_message ("debug", $subr_name, "reset selected settings"); 15386 15387 return (0); 15388 15389} #-- End of subroutine reset_selected_settings 15390 15391#------------------------------------------------------------------------------ 15392# There may be various different visibility characters in a metric definition. 15393# For example: e+%CPI. 15394# 15395# Internally we use a normalized definition that only uses the dot (e.g. 15396# e.CPI) as an index into the description structure. 15397# 15398# Here we reduce the incoming metric definition to the normalized form, look 15399# up the text, and return a pointer to it. 15400#------------------------------------------------------------------------------ 15401sub retrieve_metric_description 15402{ 15403 my $subr_name = get_my_name (); 15404 15405 my ($metric_name_ref, $metric_description_ref) = @_; 15406 15407 my $metric_name = ${ $metric_name_ref }; 15408 my %metric_description = %{ $metric_description_ref }; 15409 15410 my $description; 15411 my $normalized_metric; 15412 15413 $metric_name =~ /([ei])([\.\+%]+)(.*)/; 15414 15415 if (defined ($1) and defined ($3)) 15416 { 15417 $normalized_metric = $1 . "." . $3; 15418 } 15419 else 15420 { 15421 my $msg = "metric $metric_name has an unknown format"; 15422 gp_message ("assertion", $subr_name, $msg); 15423 } 15424 15425 if (defined ($metric_description{$normalized_metric})) 15426 { 15427 $description = $metric_description{$normalized_metric}; 15428 } 15429 else 15430 { 15431 my $msg = "description for normalized metric $normalized_metric not found"; 15432 gp_message ("assertion", $subr_name, $msg); 15433 } 15434 15435 return (\$description); 15436 15437} #-- End of subroutine retrieve_metric_description 15438 15439#------------------------------------------------------------------------------ 15440# TBD. 15441#------------------------------------------------------------------------------ 15442sub rnumerically 15443{ 15444 my ($f1,$f2); 15445 if ($a =~ /^([^\d]*)(\d+)/) 15446 { 15447 $f1 = int ($2); 15448 if ($b=~ /^([^\d]*)(\d+)/) 15449 { 15450 $f2 = int ($2); 15451 $f1 == $f2 ? 0 : ($f1 > $f2 ? -1 : +1); 15452 } 15453 } 15454 else 15455 { 15456 return ($b <=> $a); 15457 } 15458} #-- End of subroutine rnumerically 15459 15460#------------------------------------------------------------------------------ 15461# TBD: Remove - not used any longer. 15462# Set the architecture and associated regular expressions. 15463#------------------------------------------------------------------------------ 15464sub set_arch_and_regexes 15465{ 15466 my $subr_name = get_my_name (); 15467 15468 my ($arch_uname) = @_; 15469 15470 my $architecture_supported; 15471 15472 gp_message ("debug", $subr_name, "arch_uname = $arch_uname"); 15473 15474 if ($arch_uname eq "x86_64") 15475 { 15476 #x86/x64 hardware uses jump 15477 $architecture_supported = $TRUE; 15478# $arch='x64'; 15479# $regex=':\s+(j).*0x[0-9a-f]+'; 15480# $subexp='(\[\s*)(0x[0-9a-f]+)'; 15481# $linksubexp='(\[\s*)(0x[0-9a-f]+)'; 15482 gp_message ("debug", $subr_name, "detected $arch_uname hardware"); 15483 15484 $architecture_supported = $TRUE; 15485 $g_arch_specific_settings{"arch_supported"} = $TRUE; 15486 $g_arch_specific_settings{"arch"} = 'x64'; 15487 $g_arch_specific_settings{"regex"} = ':\s+(j).*0x[0-9a-f]+'; 15488 $g_arch_specific_settings{"subexp"} = '(\[\s*)(0x[0-9a-f]+)'; 15489 $g_arch_specific_settings{"linksubexp"} = '(\[\s*)(0x[0-9a-f]+)'; 15490 } 15491#------------------------------------------------------------------------------ 15492# TBD: Remove the elsif block 15493#------------------------------------------------------------------------------ 15494 elsif ($arch_uname=~m/sparc/s) 15495 { 15496 #sparc hardware uses branch 15497 $architecture_supported = $FALSE; 15498# $arch='sparc'; 15499# $regex=':\s+(c|b|fb).*0x[0-9a-f]+\s*$'; 15500# $subexp='(\s*)(0x[0-9a-f]+)\s*$'; 15501# $linksubexp='(\s*)(0x[0-9a-f]+\s*$)'; 15502# gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch - this is no longer supported"); 15503 $architecture_supported = $FALSE; 15504 $g_arch_specific_settings{arch_supported} = $FALSE; 15505 $g_arch_specific_settings{arch} = 'sparc'; 15506 $g_arch_specific_settings{regex} = ':\s+(c|b|fb).*0x[0-9a-f]+\s*$'; 15507 $g_arch_specific_settings{subexp} = '(\s*)(0x[0-9a-f]+)\s*$'; 15508 $g_arch_specific_settings{linksubexp} = '(\s*)(0x[0-9a-f]+\s*$)'; 15509 } 15510 else 15511 { 15512 $architecture_supported = $FALSE; 15513 gp_message ("debug", $subr_name, "detected $arch_uname hardware - this not supported; limited functionality"); 15514 } 15515 15516 return ($architecture_supported); 15517 15518} #-- End of subroutine set_arch_and_regexes 15519 15520#------------------------------------------------------------------------------ 15521# Set the background color of the input string. 15522# 15523# For supported colors, see: 15524# https://www.w3schools.com/colors/colors_names.asp 15525#------------------------------------------------------------------------------ 15526sub set_background_color_string 15527{ 15528 my $subr_name = get_my_name (); 15529 15530 my ($input_string, $color) = @_; 15531 15532 my $background_color_string; 15533 my $msg; 15534 15535 $msg = "color = $color input_string = $input_string"; 15536 gp_message ("debugXL", $subr_name, $msg); 15537 15538 $background_color_string = "<span style='background-color: " . $color . 15539 "'>" . $input_string . "</span>"; 15540 15541 $msg = "color = $color background_color_string = " . 15542 $background_color_string; 15543 gp_message ("debugXL", $subr_name, $msg); 15544 15545 return ($background_color_string); 15546 15547} #-- End of subroutine set_background_color_string 15548 15549#------------------------------------------------------------------------------ 15550# Set the g_debug_size structure for a given value for "size". Also set the 15551# value in $g_user_settings{"debug"}{"current_value"} 15552#------------------------------------------------------------------------------ 15553sub set_debug_size 15554{ 15555 my $subr_name = get_my_name (); 15556 15557 my $debug_value = lc ($g_user_settings{"debug"}{"current_value"}); 15558 15559#------------------------------------------------------------------------------ 15560# Set the corresponding sizes in the table. A value of "on" is equivalent to 15561# size "s". 15562#------------------------------------------------------------------------------ 15563 if (($debug_value eq "on") or ($debug_value eq "s")) 15564 { 15565 $g_debug_size{"on"} = $TRUE; 15566 $g_debug_size{"s"} = $TRUE; 15567 } 15568 elsif ($debug_value eq "m") 15569 { 15570 $g_debug_size{"on"} = $TRUE; 15571 $g_debug_size{"s"} = $TRUE; 15572 $g_debug_size{"m"} = $TRUE; 15573 } 15574 elsif ($debug_value eq "l") 15575 { 15576 $g_debug_size{"on"} = $TRUE; 15577 $g_debug_size{"s"} = $TRUE; 15578 $g_debug_size{"m"} = $TRUE; 15579 $g_debug_size{"l"} = $TRUE; 15580 } 15581 elsif ($debug_value eq "xl") 15582 { 15583 $g_debug_size{"on"} = $TRUE; 15584 $g_debug_size{"s"} = $TRUE; 15585 $g_debug_size{"m"} = $TRUE; 15586 $g_debug_size{"l"} = $TRUE; 15587 $g_debug_size{"xl"} = $TRUE; 15588 } 15589 else 15590#------------------------------------------------------------------------------ 15591# Any other value is considered to disable debugging. 15592#------------------------------------------------------------------------------ 15593 { 15594## $g_user_settings{"debug"}{"current_value"} = "off"; 15595 $g_debug = $FALSE; 15596 $g_debug_size{"on"} = $FALSE; 15597 $g_debug_size{"s"} = $FALSE; 15598 $g_debug_size{"m"} = $FALSE; 15599 $g_debug_size{"l"} = $FALSE; 15600 $g_debug_size{"xl"} = $FALSE; 15601 } 15602 15603#------------------------------------------------------------------------------ 15604# Activate in case of an emergency :-) 15605#------------------------------------------------------------------------------ 15606 my $show_sizes = $FALSE; 15607 15608 if ($show_sizes) 15609 { 15610 if ($g_debug_size{$debug_value}) 15611 { 15612 for my $i (keys %g_debug_size) 15613 { 15614 print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n"; 15615 } 15616 } 15617 } 15618 15619 return (0); 15620 15621} #-- End of subroutine set_debug_size 15622 15623#------------------------------------------------------------------------------ 15624# This subroutine defines the default metrics. 15625#------------------------------------------------------------------------------ 15626sub set_default_metrics 15627{ 15628 my $subr_name = get_my_name (); 15629 15630 my ($outfile1, $ignored_metrics_ref) = @_; 15631 15632 my %ignored_metrics = %{ $ignored_metrics_ref }; 15633 15634 my %metric_description = (); 15635 my %metric_found = (); 15636 15637 my $detail_metrics; 15638 my $detail_metrics_system; 15639 15640 my $call_metrics = ""; 15641 my $summary_metrics = ""; 15642 15643 open (METRICS, "<", $outfile1) 15644 or die ("Unable to open metrics file $outfile1 for reading - '$!'"); 15645 gp_message ("debug", $subr_name, "opened $outfile1 for reading"); 15646 15647 while (<METRICS>) 15648 { 15649 my $metric_line = $_; 15650 chomp ($metric_line); 15651 15652 gp_message ("debug", $subr_name,"the value of metric_line = $metric_line"); 15653 15654#------------------------------------------------------------------------------ 15655# Decode the metric part of the input line. If a valid line, return the 15656# metric components. Otherwise return "skipped" in the metric_spec field. 15657#------------------------------------------------------------------------------ 15658 my ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, 15659 $metric_description) = extract_metric_specifics ($metric_line); 15660 15661 gp_message ("debug", $subr_name, "metric_spec = $metric_spec"); 15662 gp_message ("debug", $subr_name, "metric_flavor = $metric_flavor"); 15663 15664 if ($metric_spec eq "skipped") 15665#------------------------------------------------------------------------------ 15666# Not a valid input line. 15667#------------------------------------------------------------------------------ 15668 { 15669 gp_message ("debug", $subr_name, "skipped line: $metric_line"); 15670 } 15671 else 15672 { 15673#------------------------------------------------------------------------------ 15674# A valid metric field has been found. 15675#------------------------------------------------------------------------------ 15676 gp_message ("debug", $subr_name, "metric_name = $metric_name"); 15677 gp_message ("debug", $subr_name, "metric_description = $metric_description"); 15678 15679# if (exists ($IMETRICS{$m})){ 15680 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{$metric_name})) 15681 { 15682 gp_message ("debug", $subr_name, "user requested to ignore metric $metric_name"); 15683 next; 15684 } 15685 15686#------------------------------------------------------------------------------ 15687# Only the exclusive metric is selected. 15688#------------------------------------------------------------------------------ 15689 if ($metric_flavor eq "e") 15690 { 15691 $metric_found{$metric_spec} = $TRUE; 15692 $metric_description{$metric_spec} = $metric_description; 15693 15694# TBD: remove the -AO: 15695 gp_message ("debug", $subr_name,"-AO metric_description{$metric_spec} = $metric_description{$metric_spec}"); 15696 15697 $summary_metrics .= $metric_spec.":"; 15698 $call_metrics .= "a.".$metric_name.":"; 15699 } 15700 } 15701 } 15702 close (METRICS); 15703 15704 chop ($call_metrics); 15705 chop ($summary_metrics); 15706 15707 $detail_metrics = $summary_metrics; 15708 $detail_metrics_system = $summary_metrics; 15709 15710 return (\%metric_description, \%metric_found, 15711 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics); 15712 15713} #-- End of subroutine set_default_metrics 15714 15715#------------------------------------------------------------------------------ 15716# Set various system specific variables. These depend upon both the processor 15717# architecture and OS. The values are stored in global structure 15718# g_arch_specific_settings. 15719#------------------------------------------------------------------------------ 15720sub set_system_specific_variables 15721{ 15722 my $subr_name = get_my_name (); 15723 15724 my ($arch_uname, $arch_uname_s) = @_; 15725 15726 my $elf_arch; 15727 my $read_elf_cmd; 15728 my $elf_support; 15729 my $architecture_supported; 15730 my $arch; 15731 my $regex; 15732 my $subexp; 15733 my $linksubexp; 15734 15735 if ($arch_uname eq "x86_64") 15736 { 15737#------------------------------------------------------------------------------ 15738# x86/x64 hardware uses jump 15739#------------------------------------------------------------------------------ 15740 $architecture_supported = $TRUE; 15741 $arch = 'x64'; 15742 $regex =':\s+(j).*0x[0-9a-f]+'; 15743 $subexp ='(\[\s*)(0x[0-9a-f]+)'; 15744 $linksubexp ='(\[\s*)(0x[0-9a-f]+)'; 15745 15746# gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch"); 15747 15748 $g_arch_specific_settings{"arch_supported"} = $TRUE; 15749 $g_arch_specific_settings{"arch"} = 'x64'; 15750#------------------------------------------------------------------------------ 15751# Define the regular expressions to parse branch instructions. 15752#------------------------------------------------------------------------------ 15753 15754#------------------------------------------------------------------------------ 15755# TBD: Need much more than these 15756#------------------------------------------------------------------------------ 15757 $g_arch_specific_settings{"regex"} = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)'; 15758 $g_arch_specific_settings{"subexp"} = '(0x[0-9a-f]+)'; 15759 $g_arch_specific_settings{"linksubexp"} = '(\s*)(0x[0-9a-f]+)'; 15760 } 15761 else 15762 { 15763 $architecture_supported = $FALSE; 15764 $g_arch_specific_settings{"arch_supported"} = $FALSE; 15765 } 15766 15767#------------------------------------------------------------------------------ 15768# TBD Ruud: need to handle this better 15769#------------------------------------------------------------------------------ 15770 if ($arch_uname_s eq "Linux") 15771 { 15772 $elf_arch = $arch_uname_s; 15773 $read_elf_cmd = $g_mapped_cmds{"readelf"}; 15774 15775 if ($read_elf_cmd eq "road to nowhere") 15776 { 15777 $elf_support = $FALSE; 15778 } 15779 else 15780 { 15781 $elf_support = $TRUE; 15782 } 15783 gp_message ("debugXL", $subr_name, "elf_support = $elf_support read_elf_cmd = $read_elf_cmd elf_arch = $elf_arch"); 15784 } 15785 else 15786 { 15787 gp_message ("abort", $subr_name, "the $arch_uname_s operating system is not supported"); 15788 } 15789 15790 return ($architecture_supported, $elf_arch, $elf_support); 15791 15792} #-- End of subroutine set_system_specific_variables 15793 15794#------------------------------------------------------------------------------ 15795# TBD 15796#------------------------------------------------------------------------------ 15797sub set_title 15798{ 15799 my $subr_name = get_my_name (); 15800 15801 my ($function_info_ref, $func, $from_where) = @_ ; 15802 15803 my $msg; 15804 my @function_info = @{$function_info_ref}; 15805 my $filename = $func ; 15806 15807 my $base; 15808 my $first_line; 15809 my $file_is_empty; 15810 my $src_file; 15811 my $RI; 15812 my $the_title; 15813 my $routine = "?"; 15814 my $DIS; 15815 my $SRC; 15816 15817 chomp ($filename); 15818 15819 $base = get_basename ($filename); 15820 15821 gp_message ("debug", $subr_name, "from_where = $from_where"); 15822 gp_message ("debug", $subr_name, "base = $base filename = $filename"); 15823 15824 if ($from_where eq "process source") 15825 { 15826 if ($base =~ /^file\.(\d+)\.src\.txt$/) 15827 { 15828 if (defined ($1)) 15829 { 15830 $RI = $1; 15831 } 15832 else 15833 { 15834 $msg = "unexpected error encountered parsing $filename"; 15835 gp_message ("assertion", $subr_name, $msg); 15836 } 15837 } 15838 $the_title = "Source"; 15839 } 15840 elsif ($from_where eq "disassembly") 15841 { 15842 if ($base =~ /^file\.(\d+)\.dis$/) 15843 { 15844 if (defined ($1)) 15845 { 15846 $RI = $1; 15847 } 15848 else 15849 { 15850 $msg = "unexpected error encountered parsing $filename"; 15851 gp_message ("assertion", $subr_name, $msg); 15852 } 15853 } 15854 $the_title = "Disassembly"; 15855 } 15856 else 15857 { 15858 $msg = "called from unknown routine - $from_where"; 15859 gp_message ("assertion", $subr_name, $msg); 15860 } 15861 15862 if (defined ($function_info[$RI]{"routine"})) 15863 { 15864 $routine = $function_info[$RI]{"routine"}; 15865 } 15866 15867 if ($from_where eq "process source") 15868 { 15869 $file_is_empty = is_file_empty ($filename); 15870 15871 if ($file_is_empty) 15872 { 15873 $src_file = ""; 15874 } 15875 else 15876 { 15877 open ($SRC, "<", $filename) 15878 or die ("$subr_name - unable to open source file $filename for reading:'$!'"); 15879 gp_message ("debug", $subr_name, "opened file $filename for reading"); 15880 15881 $first_line = <$SRC>; 15882 chomp ($first_line); 15883 15884 close ($SRC); 15885 15886 gp_message ("debug", $subr_name, "first_line = $first_line"); 15887 15888 if ($first_line =~ /^Source\s+file:\s+([^\s]+)/) 15889 { 15890 $src_file = $1 15891 } 15892 else 15893 { 15894 $src_file = ""; 15895 } 15896 } 15897 } 15898 elsif ($from_where eq "disassembly") 15899 { 15900 $msg = "unable to open disassembly file $filename for reading:"; 15901 open ($DIS, "<", $filename) 15902 or die ($subr_name . " - " . $msg . " " . $!); 15903 gp_message ("debug", $subr_name, "opened file $filename for reading"); 15904 15905 $file_is_empty = is_file_empty ($filename); 15906 15907 if ($file_is_empty) 15908#------------------------------------------------------------------------------ 15909# Currently, the disassembly file for <static> functions appears to be empty 15910# on aarch64. This might be a bug, but it is in any case better to handle 15911# this situation. 15912#------------------------------------------------------------------------------ 15913 { 15914 $first_line = ""; 15915 $msg = "file $filename is empty"; 15916 gp_message ("debugM", $subr_name, $msg); 15917 } 15918 else 15919 { 15920 $first_line = <$DIS>; 15921 } 15922 15923 close ($DIS); 15924 15925 if ($first_line =~ /^Source\s+file:\s+([^\s]+)/) 15926 { 15927 $src_file = "$1" 15928 } 15929 else 15930 { 15931 $src_file = ""; 15932 } 15933 } 15934 15935 if (length ($routine)) 15936 { 15937 $the_title .= " $routine"; 15938 } 15939 15940 if (length ($src_file)) 15941 { 15942 if ($src_file ne "(unknown)") 15943 { 15944 $the_title .= " ($src_file)"; 15945 } 15946 else 15947 { 15948 $the_title .= " $src_file"; 15949 } 15950 } 15951 15952 return ($the_title); 15953 15954} #-- End of subroutine set_title 15955 15956#------------------------------------------------------------------------------ 15957# Handles where the output should go. If needed, a directory to store the 15958# results in is created. 15959#------------------------------------------------------------------------------ 15960sub set_up_output_directory 15961{ 15962 my $subr_name = get_my_name (); 15963 15964 my $error_code; 15965 my $msg; 15966 my $mkdir_output_msg; 15967 my $outputdir = "does_not_exist_yet"; 15968 my $rm_output_msg; 15969 my $success; 15970 my $target_cmd; 15971 15972 my $define_new_output_dir = $g_user_settings{"output"}{"defined"}; 15973 my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"}; 15974 15975 if ((not $define_new_output_dir) and (not $overwrite_output_dir)) 15976#------------------------------------------------------------------------------ 15977# If neither -o or -O are set, find the next number to be used in the name for 15978# the default output directory. 15979#------------------------------------------------------------------------------ 15980 { 15981 my $dir_id = 1; 15982 while (-d "display.".$dir_id.".html") 15983 { $dir_id++; } 15984 $outputdir = "display.".$dir_id.".html"; 15985 } 15986 elsif ($define_new_output_dir) 15987#------------------------------------------------------------------------------ 15988# The output directory is defined with the -o option. 15989#------------------------------------------------------------------------------ 15990 { 15991 $outputdir = $g_user_settings{"output"}{"current_value"}; 15992 } 15993 elsif ($overwrite_output_dir) 15994#------------------------------------------------------------------------------ 15995# The output directory is defined with the -O option. 15996#------------------------------------------------------------------------------ 15997 { 15998 $outputdir = $g_user_settings{"overwrite"}{"current_value"}; 15999 } 16000 16001#------------------------------------------------------------------------------ 16002# The name of the output directory is known and we can proceed. 16003#------------------------------------------------------------------------------ 16004 $msg = "the target output directory is $outputdir"; 16005 gp_message ("debug", $subr_name, $msg); 16006 16007 if (-d $outputdir) 16008 { 16009#------------------------------------------------------------------------------ 16010# The -o option is used, but the directory already exists. 16011#------------------------------------------------------------------------------ 16012 if ($define_new_output_dir) 16013 { 16014 $msg = "directory $outputdir already exists"; 16015 gp_message ("error", $subr_name, $msg); 16016 $msg = "use the -O/--overwite option to overwrite an"; 16017 $msg .= " existing directory"; 16018 gp_message ("error", $subr_name, $msg); 16019 16020 $g_total_error_count++; 16021 16022 gp_message ("abort", $subr_name, $g_abort_msg); 16023 16024 } 16025 elsif ($overwrite_output_dir) 16026#------------------------------------------------------------------------------ 16027# It is a bit risky to remove this directory and so we proceed with caution. 16028# What if the user decides to call it "*" e.g. "-O \*" for example? While this 16029# should have been caught when processing the options, we still like to 16030# be very cautious here before executing /bin/rm -rf. 16031#------------------------------------------------------------------------------ 16032 { 16033 if ($outputdir eq "*") 16034 { 16035 $msg = "it is not allowed to use * as a value for the -O option"; 16036 gp_message ("error", $subr_name, $msg); 16037 16038 $g_total_error_count++; 16039 16040 gp_message ("abort", $subr_name, $g_abort_msg); 16041 } 16042 else 16043 { 16044#------------------------------------------------------------------------------ 16045# The output directory exists, but it is okay to overwrite it. It is 16046# removed here and created again below. 16047#------------------------------------------------------------------------------ 16048 $target_cmd = $g_mapped_cmds{"rm"} . " -rf " . $outputdir; 16049 ($error_code, $rm_output_msg) = execute_system_cmd ($target_cmd); 16050 16051 if ($error_code != 0) 16052 { 16053 $msg = "fatal error when trying to remove $outputdir"; 16054 gp_message ("error", $subr_name, $rm_output_msg); 16055 gp_message ("error", $subr_name, $msg); 16056 16057 $g_total_error_count++; 16058 16059 gp_message ("abort", $subr_name, $g_abort_msg); 16060 } 16061 else 16062 { 16063 $msg = "directory $outputdir has been removed"; 16064 gp_message ("debug", $subr_name, $msg); 16065 } 16066 } 16067 } 16068 } #-- End of if-check for $outputdir 16069 16070#------------------------------------------------------------------------------ 16071# When we get here, the fatal scenarios have not occurred and the name for 16072# $outputdir is known. Time to create it. Note that recursive creation is 16073# supported and the user umask settings control the access permissions. 16074#------------------------------------------------------------------------------ 16075 $target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir; 16076 ($error_code, $mkdir_output_msg) = execute_system_cmd ($target_cmd); 16077 16078 if ($error_code != 0) 16079 { 16080 $msg = "a fatal problem occurred when creating directory $outputdir"; 16081 gp_message ("error", $subr_name, $mkdir_output_msg); 16082 gp_message ("error", $subr_name, $msg); 16083 16084 $g_total_error_count++; 16085 16086 gp_message ("abort", $subr_name, $g_abort_msg); 16087 } 16088 else 16089 { 16090 $msg = "created output directory $outputdir"; 16091 gp_message ("debug", $subr_name, $msg); 16092 } 16093 16094 return ($outputdir); 16095 16096} #-- End of subroutine set_up_output_directory 16097 16098#------------------------------------------------------------------------------ 16099# Split a line with function data into 3 components. 16100#------------------------------------------------------------------------------ 16101sub split_function_data_line 16102{ 16103 my $subr_name = get_my_name (); 16104 16105 my ($input_line_ref) = @_; 16106 16107 my $input_line = ${ $input_line_ref }; 16108 16109 my $decimal_separator = $g_locale_settings{"decimal_separator"}; 16110 my $full_hex_address; 16111 my $function_name; 16112 my $hex_address; 16113 my $length_metric_list; 16114 my $length_remainder; 16115 my $length_target_string; 16116 my $list_with_metrics; 16117 my $marker; 16118 my $msg; 16119 my $reduced_line; 16120 my $remainder; 16121 16122 my @hex_addresses = (); 16123 my @special_marker = (); 16124 my @the_function_name = (); 16125 16126 my $find_hex_address_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(.*)'; 16127 my $find_marker_regex = '(^\*).*'; 16128 my $find_metrics_1_regex = '\)*\ +([0-9,' . $decimal_separator; 16129 $find_metrics_1_regex .= '\ ]*$)'; 16130 my $find_metrics_2_regex = '\)*\ +\[.+\]\s+([0-9,' . $decimal_separator; 16131 $find_metrics_2_regex = '\ ]*$)'; 16132 my $get_hex_address_regex = '(\d+):0x(\S+)'; 16133 16134 $reduced_line = $input_line; 16135 16136 if ($input_line =~ /$find_hex_address_regex/) 16137 { 16138 if (defined ($1) ) 16139 { 16140 $full_hex_address = $1; 16141 $reduced_line =~ s/$full_hex_address//; 16142 16143 $msg = "full_hex_address = " . $full_hex_address; 16144 gp_message ("debugXL", $subr_name, $msg); 16145 $msg = "reduced_line = " . $reduced_line; 16146 gp_message ("debugXL", $subr_name, $msg); 16147 } 16148 if (defined ($2) ) 16149 { 16150 $remainder = $2; 16151 $msg = "remainder = " . $remainder; 16152 gp_message ("debugXL", $subr_name, $msg); 16153 16154 if (($remainder =~ /$find_metrics_1_regex/) or 16155 ($remainder =~ /$find_metrics_2_regex/)) 16156 { 16157 if (defined ($1)) 16158 { 16159 $list_with_metrics = $1; 16160 $msg = "before list_with_metrics = " . $list_with_metrics; 16161 gp_message ("debugXL", $subr_name, $msg); 16162 16163 $list_with_metrics =~ s/$g_rm_surrounding_spaces_regex//g; 16164 $msg = "after list_with_metrics = " . $list_with_metrics; 16165 gp_message ("debugXL", $subr_name, $msg); 16166 16167#------------------------------------------------------------------------------ 16168# Remove the function name from the string. 16169#------------------------------------------------------------------------------ 16170 $length_remainder = length ($remainder); 16171 $length_metric_list = length ($list_with_metrics); 16172 16173 $msg = "length remainder = " . $length_remainder; 16174 gp_message ("debugXL", $subr_name, $msg); 16175 16176 $msg = "length list_with_metrics = " . $length_metric_list; 16177 gp_message ("debugXL", $subr_name, $msg); 16178 16179 $length_target_string = $length_remainder - 16180 $length_metric_list - 1; 16181 $function_name = substr ($remainder, 0, 16182 $length_target_string, ''); 16183 16184 $msg = "new function_name = " . $function_name; 16185 gp_message ("debugXL", $subr_name, $msg); 16186 16187 $reduced_line = $function_name; 16188 $reduced_line =~ s/$g_rm_surrounding_spaces_regex//g; 16189 16190 $msg = "reduced_line = " . $reduced_line; 16191 gp_message ("debugXL", $subr_name, $msg); 16192 16193#------------------------------------------------------------------------------ 16194# In some lines, the function name has a "*" prepended. Isolate this marker 16195# and later on remove it from the function name. 16196# TBD: Can probably be done more efficiently. 16197#------------------------------------------------------------------------------ 16198 if ($reduced_line =~ /$find_marker_regex/) 16199 { 16200 if (defined ($1)) 16201 { 16202 $marker = $1; 16203 $msg = "found the marker = " . $marker; 16204 gp_message ("debugXL", $subr_name, $msg); 16205 } 16206 else 16207 { 16208 $msg = "first character in " . $reduced_line ; 16209 $msg .= " is not expected"; 16210 gp_message ("assertion", $subr_name, $msg); 16211 } 16212 } 16213 else 16214 { 16215 $marker = "X"; 16216 } 16217 } 16218 else 16219 { 16220 $msg = "failure to find metric values following the "; 16221 $msg .= "function name"; 16222 gp_message ("assertion", $subr_name, $msg); 16223 } 16224 } 16225 else 16226 { 16227 $msg = "cannot find metric values in remainder"; 16228 gp_message ("debugXL", $subr_name, $msg); 16229 gp_message ("assertion", $subr_name, $msg); 16230 } 16231 } 16232#------------------------------------------------------------------------------ 16233# We now have the 3 main objects from the input line. Next, they are processed 16234# and stored. 16235#------------------------------------------------------------------------------ 16236 if ($full_hex_address =~ /$get_hex_address_regex/) 16237 { 16238 if (defined ($1) and defined ($2)) 16239 { 16240 $hex_address = "0x" . $2; 16241 push (@hex_addresses, $full_hex_address); 16242 16243 $msg = "pushed full_hex_address = " . $full_hex_address; 16244 gp_message ("debugXL", $subr_name, $msg); 16245 } 16246 } 16247 else 16248 { 16249 $msg = "full_hex_address = $full_hex_address has an unknown format"; 16250 gp_message ("assertion", $subr_name, $msg); 16251 } 16252 if ($marker eq "*") 16253 { 16254 push (@special_marker, "*"); 16255 } 16256 else 16257 { 16258 push (@special_marker, "X"); 16259 } 16260 16261 $reduced_line =~ s/^\*//; 16262 16263 $msg = "RESULT full_hex_address = " . $full_hex_address; 16264 $msg .= " -- metric values = " . $list_with_metrics; 16265 $msg .= " -- marker = " . $marker; 16266 $msg .= " -- function name = " . $reduced_line; 16267 gp_message ("debugXL", $subr_name, $msg); 16268 } 16269 16270 return (\$full_hex_address, \$marker, \$reduced_line, \$list_with_metrics); 16271 16272} #-- End of subroutine split_function_data_line 16273 16274#------------------------------------------------------------------------------ 16275# Routine to generate webfriendly names 16276#------------------------------------------------------------------------------ 16277sub tag_name 16278{ 16279 my $subr_name = get_my_name (); 16280 16281 my ($target_name) = @_; 16282 16283#------------------------------------------------------------------------------ 16284# Keeps track how many names have been tagged already. 16285#------------------------------------------------------------------------------ 16286 state $S_total_tagged_names = 0; 16287 16288 my $msg; 16289 my $unique_name; 16290 16291 gp_message ("debug", $subr_name, "target_name on entry = $target_name"); 16292 16293#------------------------------------------------------------------------------ 16294# Undo conversion of < in to < 16295#------------------------------------------------------------------------------ 16296 16297#------------------------------------------------------------------------------ 16298# TBD: Legacy - What is going on here and is this really needed?! 16299# We need to replace the "<" symbol in the code by "<". 16300#------------------------------------------------------------------------------ 16301 $target_name =~ s/$g_html_less_than_regex/$g_less_than_regex/g; 16302 16303#------------------------------------------------------------------------------ 16304# Remove inlining info 16305#------------------------------------------------------------------------------ 16306 $target_name =~ s/, instructions from source file.*//; 16307 16308 if (defined $g_tagged_names{$target_name}) 16309 { 16310 $msg = "target_name = $target_name is already defined: "; 16311 $msg .= $g_tagged_names{$target_name}; 16312 gp_message ("debug", $subr_name, $msg); 16313 16314 $msg = "target_name on return = $target_name"; 16315 gp_message ("debug", $subr_name, $msg); 16316 16317 return ($g_tagged_names{$target_name}); 16318 } 16319 else 16320 { 16321 $unique_name = "ftag".$S_total_tagged_names; 16322 $S_total_tagged_names++; 16323 $g_tagged_names{$target_name} = $unique_name; 16324 16325 $msg = "target_name = $target_name is new and added: "; 16326 $msg .= "g_tagged_names{$target_name} = $g_tagged_names{$target_name}"; 16327 gp_message ("debug", $subr_name, $msg); 16328 16329 $msg = "target_name on return = $target_name"; 16330 gp_message ("debug", $subr_name, $msg); 16331 16332 return ($unique_name); 16333 } 16334 16335} #-- End of subroutine tag_name 16336 16337#------------------------------------------------------------------------------ 16338# Generate a string to terminate the HTML document. 16339#------------------------------------------------------------------------------ 16340sub terminate_html_document 16341{ 16342 my $subr_name = get_my_name (); 16343 16344 my $html_line; 16345 16346 $html_line = "</body>\n"; 16347 $html_line .= "</html>"; 16348 16349 return (\$html_line); 16350 16351} #-- End of subroutine terminate_html_document 16352 16353#------------------------------------------------------------------------------ 16354# Perform some basic checks to ensure the input data is consistent. This part 16355# could be refined and expanded over time. For example by using a checksum 16356# mechanism to verify the consistency of the executables. 16357#------------------------------------------------------------------------------ 16358sub verify_consistency_experiments 16359{ 16360 my $subr_name = get_my_name (); 16361 16362 my ($exp_dir_list_ref) = @_; 16363 16364 my @exp_dir_list = @{ $exp_dir_list_ref }; 16365 16366 my $executable_name; 16367 my $full_path_executable_name; 16368 my $msg; 16369 my $ref_executable_name; 16370 16371 my $first_exp_dir = $TRUE; 16372 my $count_differences = 0; 16373 16374#------------------------------------------------------------------------------ 16375# Enforce that the full path names to the executable are the same. This could 16376# be overkill and a checksum approach would be more flexible. 16377#------------------------------------------------------------------------------ 16378 for my $full_exp_dir (@exp_dir_list) 16379 { 16380 my $exp_dir = get_basename ($full_exp_dir); 16381 gp_message ("debug", $subr_name, "exp_dir = $exp_dir"); 16382 if ($first_exp_dir) 16383 { 16384 $first_exp_dir = $FALSE; 16385 $ref_executable_name = 16386 $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; 16387 $msg = "ref_executable_name = " . $ref_executable_name; 16388 gp_message ("debug", $subr_name, $msg); 16389 next; 16390 } 16391 $full_path_executable_name = 16392 $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"}; 16393 $msg = "full_path_executable_name = " . $full_path_executable_name; 16394 gp_message ("debug", $subr_name, $msg); 16395 16396 if ($full_path_executable_name ne $ref_executable_name) 16397 { 16398 $count_differences++; 16399 $msg = $full_path_executable_name . " does not match"; 16400 $msg .= " " . $ref_executable_name; 16401 gp_message ("debug", $subr_name, $msg); 16402 } 16403 } 16404 16405 $executable_name = get_basename ($ref_executable_name); 16406 16407 return ($count_differences, $executable_name); 16408 16409} #-- End of subroutine verify_consistency_experiments 16410 16411#------------------------------------------------------------------------------ 16412# Check if the input item is valid for the data type specified. Validity is 16413# verified in the context of gprofng. The definition for the metrics is a 16414# good example of that. 16415#------------------------------------------------------------------------------ 16416sub verify_if_input_is_valid 16417{ 16418 my $subr_name = get_my_name (); 16419 16420 my ($input_item, $data_type) = @_; 16421 16422 my $msg; 16423 my $return_value = $FALSE; 16424 16425#------------------------------------------------------------------------------ 16426# These value are allowed to be case insensitive, so we convert to lower 16427# case first. 16428#------------------------------------------------------------------------------ 16429 if (($data_type eq "onoff") or ($data_type eq "size")) 16430 { 16431 $input_item = lc ($input_item); 16432 } 16433 16434 if ($data_type eq "metrics") 16435#------------------------------------------------------------------------------ 16436# A gprofng metric definition. Either consists of "default" only, or starts 16437# with e or i, followed by one or more from the set {.,%,!,+} and a keyword. 16438# This pattern may be repeated with a ":" as the separator. 16439#------------------------------------------------------------------------------ 16440 { 16441 my @metric_list = split (":", $input_item); 16442 16443#------------------------------------------------------------------------------ 16444# Check if the pattern is valid. If not, bail out and return $FALSE. 16445#------------------------------------------------------------------------------ 16446 for my $metric (@metric_list) 16447 { 16448 if ($metric =~ /^default$|^[ei]*[\.%\!\+]+[a-z]*$/) 16449 { 16450 $return_value = $TRUE; 16451 } 16452 else 16453 { 16454 $return_value = $FALSE; 16455 last; 16456 } 16457 } 16458 } 16459 elsif ($data_type eq "metric_names") 16460#------------------------------------------------------------------------------ 16461# A gprofng metric definition but without the flavour and visibility . Either 16462# the name consists of "default" only, or a keyword with lowercase letters 16463# only. This pattern may be repeated with a ":" as the separator. 16464#------------------------------------------------------------------------------ 16465 { 16466 my @metric_list = split (":", $input_item); 16467 16468#------------------------------------------------------------------------------ 16469# Check if the pattern is valid. If not, bail out and return $FALSE. 16470#------------------------------------------------------------------------------ 16471 for my $metric (@metric_list) 16472 { 16473 if ($metric =~ /^default$|^[a-z]*$/) 16474 { 16475 $return_value = $TRUE; 16476 } 16477 else 16478 { 16479 $return_value = $FALSE; 16480 last; 16481 } 16482 } 16483 } 16484 elsif ($data_type eq "path") 16485#------------------------------------------------------------------------------ 16486# This can be almost anything, including "/" and "." 16487#------------------------------------------------------------------------------ 16488 { 16489 if ($input_item =~ /^[\w\/\.\-]*$/) 16490 { 16491 $return_value = $TRUE; 16492 } 16493 } 16494 elsif ($data_type eq "boolean") 16495 { 16496#------------------------------------------------------------------------------ 16497# This is TRUE (=1) or FALSE (0). 16498#------------------------------------------------------------------------------ 16499 if ($input_item =~ /^[01]$/) 16500 { 16501 $return_value = $TRUE; 16502 } 16503 } 16504 elsif ($data_type eq "onoff") 16505#------------------------------------------------------------------------------ 16506# This is either "on" OR "off". 16507#------------------------------------------------------------------------------ 16508 { 16509 if ($input_item =~ /^on$|^off$/) 16510 { 16511 $return_value = $TRUE; 16512 } 16513 } 16514 elsif ($data_type eq "size") 16515#------------------------------------------------------------------------------ 16516# Supported values are "on", "off", "s", "m", "l", or "xl". 16517#------------------------------------------------------------------------------ 16518 { 16519 if ($input_item =~ /^on$|^off$|^s$|^m$|^l$|^xl$/) 16520 { 16521 $return_value = $TRUE; 16522 } 16523 } 16524 elsif ($data_type eq "pinteger") 16525#------------------------------------------------------------------------------ 16526# This is a positive integer. 16527#------------------------------------------------------------------------------ 16528 { 16529 if ($input_item =~ /^\d*$/) 16530 { 16531 $return_value = $TRUE; 16532 } 16533 } 16534 elsif ($data_type eq "integer") 16535#------------------------------------------------------------------------------ 16536# This is a positive or negative integer. 16537#------------------------------------------------------------------------------ 16538 { 16539 if ($input_item =~ /^\-?\d*$/) 16540 { 16541 $return_value = $TRUE; 16542 } 16543 } 16544 elsif ($data_type eq "pfloat") 16545#------------------------------------------------------------------------------ 16546# This is a positive floating point number, but we accept a positive integer 16547# number as well. 16548# 16549# TBD: Note that we use the "." here. Maybe should support a "," too. 16550#------------------------------------------------------------------------------ 16551 { 16552 if (($input_item =~ /^\d*\.\d*$/) or ($input_item =~ /^\d*$/)) 16553 { 16554 $return_value = $TRUE; 16555 } 16556 } 16557 elsif ($data_type eq "float") 16558#------------------------------------------------------------------------------ 16559# This is a positive or negative floating point number, but we accept an 16560# integer number as well. 16561# 16562# TBD: Note that we use the "." here. Maybe should support a "," too. 16563#------------------------------------------------------------------------------ 16564 { 16565 if (($input_item =~ /^\-?\d*\.\d*$/) or ($input_item =~ /^\-?\d*$/)) 16566 { 16567 $return_value = $TRUE; 16568 } 16569 } 16570 else 16571 { 16572 $msg = "the $data_type data type for input $input_item is not supported"; 16573 gp_message ("assertion", $subr_name, $msg); 16574 } 16575 16576 return ($return_value); 16577 16578} #-- End of subroutine verify_if_input_is_valid 16579 16580#------------------------------------------------------------------------------ 16581# Scan the leftovers in ARGV. Other than the option generated by the driver, 16582# this list should be empty. Anything left here is considered to be a fatal 16583# error and pushed into the g_error_msgs buffer. 16584# 16585# We use two different arrays for the errors found. This allows us to group 16586# the same type of errors. 16587#------------------------------------------------------------------------------ 16588sub wrap_up_user_options 16589{ 16590 my $subr_name = get_my_name (); 16591 16592 my @opt_unsupported = (); 16593 my @opt_ignored = (); 16594 16595 my $current_option; 16596 my $driver_inserted = "--whoami=gprofng display html"; 16597 my $ignore_option; 16598 my $msg; 16599 my $option_delimiter = "--"; 16600 16601 if (@ARGV) 16602 { 16603 $msg = "items in ARGV: " . join (" ", @ARGV); 16604 gp_message ("debugXL", $subr_name, $msg); 16605 16606 $ignore_option = $FALSE; 16607 for my $i (keys @ARGV) 16608 { 16609 $current_option = $ARGV[$i]; 16610 16611 $msg = "ARGV[$i] = $current_option"; 16612 16613 if ($current_option eq $option_delimiter) 16614#------------------------------------------------------------------------------ 16615# The user may use a feature of GetOptions to delimit the options. After 16616# this, only experiment names are allowed and these have been handled already, 16617# so anything found after this delimite is an error. 16618# 16619# This is why we set a flag if the delimiter has been found. 16620#------------------------------------------------------------------------------ 16621 { 16622 $ignore_option = $TRUE; 16623 gp_message ("debugXL", $subr_name, $msg . " (option delimiter)"); 16624 } 16625 elsif ($ignore_option) 16626#------------------------------------------------------------------------------ 16627# We have seen the delimiter, but there are still options, or other strings. 16628# In any case, it is not allowed. 16629#------------------------------------------------------------------------------ 16630 { 16631 push (@opt_ignored, $current_option); 16632 gp_message ("debugXL", $subr_name, $msg . " (ignored)"); 16633 } 16634 elsif ($current_option ne $driver_inserted) 16635#------------------------------------------------------------------------------ 16636# The gprofng driver inserts this and it should be ignored. This is why we 16637# only recorded those options different than the one inserted by the driver. 16638#------------------------------------------------------------------------------ 16639 { 16640 push (@opt_unsupported, $current_option); 16641 gp_message ("debugXL", $subr_name, $msg . " (unsupported)"); 16642 } 16643 else 16644#------------------------------------------------------------------------------ 16645# The gprofng driver inserts this option and it should be ignored. 16646#------------------------------------------------------------------------------ 16647 { 16648 gp_message ("debugXL", $subr_name, $msg . 16649 " (driver inserted and ignored)"); 16650 } 16651 } 16652 } 16653 16654#------------------------------------------------------------------------------ 16655# Store any illegal input in the g_error_msgs buffer. 16656#------------------------------------------------------------------------------ 16657 if (@opt_ignored) 16658 { 16659 $msg = "the following input is out of place:"; 16660 for my $i (keys @opt_ignored) 16661 { 16662 $msg .= " " . $opt_ignored[$i]; 16663 } 16664 gp_message ("error", $subr_name, $msg); 16665 16666 $g_total_error_count++; 16667 } 16668 if (@opt_unsupported) 16669 { 16670 $msg = "the following items in the input are not supported:"; 16671 for my $i (keys @opt_unsupported) 16672 { 16673 $msg .= " " . $opt_unsupported[$i]; 16674 } 16675 gp_message ("error", $subr_name, $msg); 16676 16677 $msg = "perhaps an error in the option name, or an option value"; 16678 $msg .= " is missing?"; 16679 gp_message ("error", $subr_name, $msg); 16680 16681 $g_total_error_count++; 16682 } 16683 16684 return (0); 16685 16686} #-- End of subroutine wrap_up_user_options 16687