2 # Copyright (C) 2021-2023 Free Software Foundation, Inc.
3 # Contributed by Oracle.
5 # This file is part of GNU Binutils.
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)
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.
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,
25 # Disable before release
29 use List
::Util qw
(max
);
30 use Cwd qw
(abs_path cwd
);
33 use feature qw
(state);
35 use Getopt
::Long qw
(Configure
);
37 #------------------------------------------------------------------------------
38 # Check as early as possible if the version of Perl used is supported.
39 #------------------------------------------------------------------------------
42 my $perl_minimal_version_supported = version
->parse ("5.10.0")->normal;
43 my $perl_current_version = version
->parse ("$]")->normal;
45 if ($perl_current_version lt $perl_minimal_version_supported)
49 $msg = "Error: minimum Perl release required: ";
50 $msg .= $perl_minimal_version_supported;
52 $msg .= $perl_current_version;
61 #------------------------------------------------------------------------------
62 # Poor man's version of a boolean.
63 #------------------------------------------------------------------------------
67 #------------------------------------------------------------------------------
68 # Used to ensure correct alignment of columns.
69 #------------------------------------------------------------------------------
70 my $g_max_length_first_metric;
72 #------------------------------------------------------------------------------
73 # This variable contains the path used to execute $GP_DISPAY_TEXT.
74 #------------------------------------------------------------------------------
77 #------------------------------------------------------------------------------
79 #------------------------------------------------------------------------------
80 my $g_test_code = $FALSE;
82 #------------------------------------------------------------------------------
83 # GPROFNG commands and files used.
84 #------------------------------------------------------------------------------
85 my $GP_DISPLAY_TEXT = "gp-display-text";
87 my $g_gp_output_file = $GP_DISPLAY_TEXT.".stdout.log";
88 my $g_gp_error_logfile = $GP_DISPLAY_TEXT.".stderr.log";
90 #------------------------------------------------------------------------------
92 #------------------------------------------------------------------------------
93 my $g_addressing_mode = "64 bit";
95 #------------------------------------------------------------------------------
96 # The global regex section.
98 # First step towards consolidating all regexes.
99 #------------------------------------------------------------------------------
100 my $g_less_than_regex = '<';
101 my $g_html_less_than_regex = '<';
102 my $g_endbr_inst_regex = 'endbr[32|64]';
104 #------------------------------------------------------------------------------
105 # For consistency, use a global variable.
106 #------------------------------------------------------------------------------
107 my $g_html_new_line = "<br>";
109 #------------------------------------------------------------------------------
110 # These are the regex's used.
111 #------------------------------------------------------------------------------
112 #------------------------------------------------------------------------------
113 # Disassembly analysis
114 #------------------------------------------------------------------------------
115 my $g_branch_regex = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)';
116 my $g_endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])';
117 my $g_function_call_v2_regex =
118 '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*';
122 my $binutils_version;
127 my %g_mapped_cmds = ();
129 #------------------------------------------------------------------------------
130 # Variables dealing with warnings and errors. Since a message may span
131 # multiple lines (for readability reasons), the number of entries in the
132 # array may not reflect the total number of messages. This is why we use
133 # separate variables for the counts.
134 #------------------------------------------------------------------------------
135 my @g_error_msgs = ();
136 my @g_warning_msgs = ();
137 my $g_total_error_count = 0;
138 #------------------------------------------------------------------------------
139 # This count is used in the html_create_warnings_page HTML page to show how
140 # many warning messages there are. Warnings are printed through gp_message(),
141 # but since one warning may span multiple lines, we update a separate counter
142 # that contains the total number of warning messages issued so far.
143 #------------------------------------------------------------------------------
144 my $g_total_warning_count = 0;
145 my $g_options_printed = $FALSE;
146 my $g_abort_msg = "cannot recover from the error(s)";
148 #------------------------------------------------------------------------------
149 # Contains the names that have already been tagged. This is a global
150 # structure because otherwise the code would get much more complicated.
151 #------------------------------------------------------------------------------
152 my %g_tagged_names = ();
154 #------------------------------------------------------------------------------
155 # TBD Remove the use of these structures. No longer used.
156 #------------------------------------------------------------------------------
157 my %g_function_tag_id = ();
158 my $g_context = 5; # Defines the range of scan
160 my $g_default_setting_lang = "en-US.UTF-8";
161 my %g_exp_dir_meta_data;
163 my $g_html_credits_line;
165 my $g_warn_keyword = "[Warning]";
166 my $g_error_keyword = "[Error]";
168 my %g_function_occurrences = ();
169 my %g_map_function_to_index = ();
170 my %g_multi_count_function = ();
171 my %g_function_view_all = ();
172 my @g_full_function_view_table = ();
174 my @g_html_experiment_stats = ();
176 #------------------------------------------------------------------------------
177 # These structures contain the information printed in the function views.
178 #------------------------------------------------------------------------------
181 my @g_html_function_name = ();
183 #------------------------------------------------------------------------------
184 # TBD: This variable may not be needed and replaced by tp_value
186 #------------------------------------------------------------------------------
188 #------------------------------------------------------------------------------
189 # Define the driver command, tool name and version number.
190 #------------------------------------------------------------------------------
191 $driver_cmd = "gprofng display html";
192 $tool_name = "gp-display-html";
193 #$binutils_version = "2.38.50";
194 $binutils_version = "BINUTILS_VERSION";
195 $version_info = $tool_name . " GNU binutils version " . $binutils_version;
197 #------------------------------------------------------------------------------
199 #------------------------------------------------------------------------------
200 #------------------------------------------------------------------------------
201 # Define several key data structures.
202 #------------------------------------------------------------------------------
203 #------------------------------------------------------------------------------
205 #------------------------------------------------------------------------------
206 # This table has the settings of the variables the user may set.
207 #------------------------------------------------------------------------------
208 my %g_user_settings =
210 verbose
=> { option
=> "--verbose",
211 no_of_arguments
=> 1,
212 data_type
=> "onoff",
213 current_value
=> "off", defined => $FALSE},
215 debug
=> { option
=> "--debug",
216 no_of_arguments
=> 1,
218 current_value
=> "off", defined => $FALSE},
220 warnings
=> { option
=> "--warnings",
221 no_of_arguments
=> 1,
222 data_type
=> "onoff" ,
223 current_value
=> "off", defined => $FALSE},
225 nowarnings
=> { option
=> "--nowarnings",
226 no_of_arguments
=> 1,
227 data_type
=> "onoff",
228 current_value
=> "off", defined => $FALSE},
230 quiet
=> { option
=> "--quiet",
231 no_of_arguments
=> 1,
232 data_type
=> "onoff",
233 current_value
=> "off", defined => $FALSE},
235 output
=> { option
=> "-o",
236 no_of_arguments
=> 1,
238 current_value
=> undef, defined => $FALSE},
240 overwrite
=> { option
=> "-O",
241 no_of_arguments
=> 1,
243 current_value
=> undef, defined => $FALSE},
245 calltree
=> { option
=> "-ct",
246 no_of_arguments
=> 1,
247 data_type
=> "onoff",
248 current_value
=> "off", defined => $FALSE},
250 func_limit
=> { option
=> "-fl",
251 no_of_arguments
=> 1,
252 data_type
=> "pinteger",
253 current_value
=> 500, defined => $FALSE},
255 highlight_percentage
=> { option
=> "--highlight-percentage",
256 no_of_arguments
=> 1,
257 data_type
=> "pfloat",
258 current_value
=> 90.0, defined => $FALSE},
260 hp
=> { option
=> "-hp",
261 no_of_arguments
=> 1,
262 data_type
=> "pfloat",
263 current_value
=> 90.0, defined => $FALSE},
265 threshold_percentage
=> { option
=> "-tp",
266 no_of_arguments
=> 1,
267 data_type
=> "pfloat",
268 current_value
=> 100.0, defined => $FALSE},
270 default_metrics
=> { option
=> "-dm",
271 no_of_arguments
=> 1,
272 data_type
=> "onoff",
273 current_value
=> "off", defined => $FALSE},
275 ignore_metrics
=> { option
=> "-im",
276 no_of_arguments
=> 1,
277 data_type
=> "metric_names",
278 current_value
=> undef, defined => $FALSE},
281 #------------------------------------------------------------------------------
282 # Convenience. These map the on/off value to $TRUE/$FALSE to make the code
283 # easier to read. For example: "if ($g_verbose)" as opposed to the following:
284 # "if ($verbose_setting eq "on").
285 #------------------------------------------------------------------------------
286 my $g_verbose = $FALSE;
287 my $g_debug = $FALSE;
288 my $g_warnings = $TRUE;
289 my $g_quiet = $FALSE;
291 #------------------------------------------------------------------------------
292 # Since ARGV is modified when parsing the options, a clean copy is used to
293 # print the original ARGV values in case of a warning, or error.
294 #------------------------------------------------------------------------------
306 my %local_system_config =
308 kernel_name
=> "undefined",
309 nodename
=> "undefined",
310 kernel_release
=> "undefined",
311 kernel_version
=> "undefined",
312 machine
=> "undefined",
313 processor
=> "undefined",
314 hardware_platform
=> "undefined",
315 operating_system
=> "undefined",
316 hostname_current
=> "undefined",
319 #------------------------------------------------------------------------------
320 # Note that we use single quotes here, because regular expressions wreak
322 #------------------------------------------------------------------------------
324 my %g_arch_specific_settings =
326 arch_supported
=> $FALSE,
328 regex
=> 'undefined',
329 subexp
=> 'undefined',
330 linksubexp
=> 'undefined',
333 my %g_locale_settings = (
334 LANG
=> "en_US.UTF-8",
335 decimal_separator
=> "\\.",
336 covert_to_dot
=> $FALSE
339 #------------------------------------------------------------------------------
340 # See this page for a nice overview with the colors:
341 # https://www.w3schools.com/colors/colors_groups.asp
342 #------------------------------------------------------------------------------
344 my %g_html_color_scheme = (
345 "control_flow" => "Brown",
346 "target_function_name" => "Red",
347 "non_target_function_name" => "BlueViolet",
348 "background_color_hot" => "PeachPuff",
349 "background_color_lukewarm" => "LemonChiffon",
350 "link_outside_range" => "Crimson",
351 "error_message" => "LightPink",
352 "background_color_page" => "White",
353 # "background_color_page" => "LightGray",
354 "background_selected_sort" => "LightSlateGray",
355 "index" => "Lavender",
358 #------------------------------------------------------------------------------
359 # These are the base names for the HTML files that are generated.
360 #------------------------------------------------------------------------------
361 my %g_html_base_file_name = (
362 "caller_callee" => "caller-callee",
363 "disassembly" => "dis",
364 "experiment_info" => "experiment-info",
365 "function_view" => "function-view-sorted",
368 "warnings" => "warnings",
371 #------------------------------------------------------------------------------
372 # Introducing main() is cosmetic, but helps with the scoping of variables.
373 #------------------------------------------------------------------------------
378 #------------------------------------------------------------------------------
379 # This is the driver part of the program.
380 #------------------------------------------------------------------------------
383 my $subr_name = get_my_name
();
387 #------------------------------------------------------------------------------
388 # The name of the configuration file.
389 #------------------------------------------------------------------------------
390 my $rc_file_name = ".gp-display-html.rc";
392 #------------------------------------------------------------------------------
393 # OS commands executed and search paths.
395 # TBD: check if elfdump should be here too (most likely not though)
396 #------------------------------------------------------------------------------
397 my @selected_os_cmds = qw
(rm cat hostname locale which printenv uname
400 my @search_paths_os_cmds = qw
(
409 #------------------------------------------------------------------------------
410 # TBD: Eliminate these.
411 #------------------------------------------------------------------------------
412 my $ARCHIVES_MAP_NAME;
413 my $ARCHIVES_MAP_VADDR;
415 #------------------------------------------------------------------------------
416 # Local structures (hashes and arrays).
417 #------------------------------------------------------------------------------
418 my @exp_dir_list = ();
421 my %function_address_info = ();
422 my $function_address_info_ref;
424 my @function_info = ();
425 my $function_info_ref;
427 my %function_address_and_index = ();
428 my $function_address_and_index_ref;
430 my %addressobjtextm = ();
431 my $addressobjtextm_ref;
433 my %addressobj_index = ();
434 my $addressobj_index_ref;
439 my %function_view_structure = ();
440 my $function_view_structure_ref;
445 #------------------------------------------------------------------------------
447 #------------------------------------------------------------------------------
448 my $abs_path_outputdir;
449 my $archive_dir_not_empty;
450 my $base_va_executable;
455 my $number_of_metrics;
456 my $va_executable_in_hex;
458 my $failed_command_mappings;
460 my $script_pc_metrics;
461 my $dir_check_errors;
462 my $consistency_errors;
466 my $decimal_separator;
468 my $architecture_supported;
472 my $elf_loadobjects_found;
474 my $rc_file_paths_ref;
475 my @rc_file_paths = ();
476 my $rc_file_errors = 0;
478 my @sort_fields = ();
485 my $detail_metrics_system;
495 my %metric_value = ();
496 my %metric_description = ();
497 my %metric_description_reversed = ();
498 my %metric_found = ();
499 my %ignored_metrics = ();
501 my $metric_value_ref;
502 my $metric_description_ref;
503 my $metric_found_ref;
504 my $ignored_metrics_ref;
506 my @table_execution_stats = ();
507 my $table_execution_stats_ref;
509 my $html_first_metric_file_ref;
510 my $html_first_metric_file;
516 my $setting_for_LANG;
517 my $time_percentage_multiplier;
518 my $process_all_functions;
520 my $selected_archive;
522 #------------------------------------------------------------------------------
523 # If no options are given, print the help info and exit.
524 #------------------------------------------------------------------------------
527 $ignore_value = print_help_info
();
531 #------------------------------------------------------------------------------
532 # This part is like a preamble. Before we continue we need to figure out some
533 # things that are needed later on.
534 #------------------------------------------------------------------------------
536 #------------------------------------------------------------------------------
537 # Store the absolute path of the command executed.
538 #------------------------------------------------------------------------------
539 my $location_gp_command = $0;
541 #------------------------------------------------------------------------------
542 # Get the ball rolling. Parse and interpret the options. Some first checks
545 # Instead of bailing out on the first user error, we capture all warnings and
546 # errors. The warnings, if any, will be printed once the command line has
547 # been parsed and verified. Execution continues.
549 # Any error(s) accumulated in this phase will be printed after the command
550 # line has been parsed and verified. Execution is then terminated.
552 # In the remainder, any error encountered will immediately terminate the
553 # execution because we can't guarantee the remaining code will work up to
555 #------------------------------------------------------------------------------
556 my ($found_exp_dir_ref, $exp_dir_list_ref) = parse_and_check_user_options
();
558 $found_exp_dir = ${ $found_exp_dir_ref };
562 @exp_dir_list = @
{ $exp_dir_list_ref };
566 $msg = "the list with experiments is either missing, or incorrect";
567 gp_message
("debug", $subr_name, $msg);
570 #------------------------------------------------------------------------------
571 # The final settings for verbose, debug, warnings and quiet are known and the
572 # gp_message() subroutine is aware of these.
573 #------------------------------------------------------------------------------
574 $msg = "parsing of the user options completed";
575 gp_message
("verbose", $subr_name, $msg);
577 #------------------------------------------------------------------------------
578 # The user options have been taken in. Check for validity and consistency.
579 #------------------------------------------------------------------------------
580 $msg = "process user options";
581 gp_message
("verbose", $subr_name, $msg);
583 ($ignored_metrics_ref, $outputdir,
584 $time_percentage_multiplier, $process_all_functions, $exp_dir_list_ref) =
585 process_user_options
(\
@exp_dir_list);
587 @exp_dir_list = @
{ $exp_dir_list_ref };
588 %ignored_metrics = %{$ignored_metrics_ref};
590 #------------------------------------------------------------------------------
591 # The next subroutine is executed early to ensure the OS commands we need are
594 # This subroutine stores the commands and the full path names as an
595 # associative array called "g_mapped_cmds". The command is the key and the
596 # value is the full path. For example: ("uname", /usr/bin/uname).
597 #------------------------------------------------------------------------------
598 gp_message
("debug", $subr_name, "verify the OS commands");
599 $failed_command_mappings = check_and_define_cmds
(\
@selected_os_cmds,
600 \
@search_paths_os_cmds);
602 if ($failed_command_mappings == 0)
604 $msg = "successfully verified the OS commands";
605 gp_message
("debug", $subr_name, $msg);
608 #------------------------------------------------------------------------------
609 #------------------------------------------------------------------------------
610 # Time to check if any warnings and/or errors have been generated.
611 #------------------------------------------------------------------------------
612 #------------------------------------------------------------------------------
614 #------------------------------------------------------------------------------
615 # We have completed all the upfront checks. Print any warnings and errors.
616 # If there are already any errors, execution is terminated. As execution
617 # continues, errors may occur and they are typically fatal.
618 #------------------------------------------------------------------------------
621 $msg = "internal settings after option processing";
622 $ignore_value = print_table_user_settings
("diag", $msg);
625 #------------------------------------------------------------------------------
626 # Terminate execution in case fatal errors have occurred.
627 #------------------------------------------------------------------------------
628 if ( $g_total_error_count > 0)
630 my $msg = "the current values for the user controllable settings";
631 print_user_settings
("debug", $msg);
633 gp_message
("abort", $subr_name, $g_abort_msg);
637 my $msg = "after parsing the user options, the final values are";
638 print_user_settings
("debug", $msg);
641 #------------------------------------------------------------------------------
642 # If no option is given for the output directory, pick a default. Otherwise,
643 # if the output directory exists, wipe it clean in case the -O option is used.
644 # If not, raise an error because the -o option does not overwrite an existing
646 # Also in case of other errors, the execution is terminated.
647 #------------------------------------------------------------------------------
648 $outputdir = set_up_output_directory
();
649 $abs_path_outputdir = Cwd
::cwd
() . "/" . $outputdir;
651 $msg = "the output directory is $outputdir";
652 gp_message
("debug", $subr_name, $msg);
654 #------------------------------------------------------------------------------
655 # Get the home directory and the locations for the configuration file on the
657 #------------------------------------------------------------------------------
658 ($home_dir, $rc_file_paths_ref) = get_home_dir_and_rc_path
($rc_file_name);
660 @rc_file_paths = @
{ $rc_file_paths_ref };
662 $msg = "the home directory is $home_dir";
663 gp_message
("debug", $subr_name, $msg);
665 #------------------------------------------------------------------------------
666 # TBD: de-activated until this feature has been fully implemented.
667 #------------------------------------------------------------------------------
668 ## $msg = "the search path for the rc file is @rc_file_paths";
669 ## gp_message ("debug", $subr_name, $msg);
670 ## $pretty_dir_list = build_pretty_dir_list (\@rc_file_paths);
672 #------------------------------------------------------------------------------
673 # Get the ball rolling. Parse and interpret the configuration file (if any)
674 # and the command line options.
676 # Note that the verbose, debug, and quiet options can be set in this file.
677 # It is a deliberate choice to ignore these for now. The assumption is that
678 # the user will not be happy if we ignore the command line settings for a
680 #------------------------------------------------------------------------------
681 $msg = "processing of the rc file has been disabled for now";
682 gp_message
("debugXL", $subr_name, $msg);
684 # Temporarily disabled
685 # print_table_user_settings ("debugXL", "before function process_rc_file");
686 # $rc_file_errors = process_rc_file ($rc_file_name, $rc_file_paths_ref);
687 # if ($rc_file_errors != 0)
689 # $message = "fatal errors in file $rc_file_name encountered";
690 # gp_message ("debugXL", $subr_name, $message);
692 # print_table_user_settings ("debugXL", "after function process_rc_file");
694 #------------------------------------------------------------------------------
695 # Print a list with the experiment directory names
696 #------------------------------------------------------------------------------
697 $pretty_dir_list = build_pretty_dir_list
(\
@exp_dir_list);
699 my $plural = ($#exp_dir_list > 0) ?
"directories are" : "directory is";
701 $msg = "the experiment " . $plural . ":";
702 gp_message
("verbose", $subr_name, $msg);
703 gp_message
("verbose", $subr_name, $pretty_dir_list);
705 #------------------------------------------------------------------------------
706 # Set up the first entry with the meta data for the experiments. This field
707 # contains the absolute paths to the experiment directories.
708 #------------------------------------------------------------------------------
709 for my $exp_dir (@exp_dir_list)
711 my ($filename, $directory_path, $ignore_suffix) = fileparse
($exp_dir);
712 gp_message
("debug", $subr_name, "exp_dir = $exp_dir");
713 gp_message
("debug", $subr_name, "filename = $filename");
714 gp_message
("debug", $subr_name, "directory_path = $directory_path");
715 $g_exp_dir_meta_data{$filename}{"directory_path"} = $directory_path;
718 #------------------------------------------------------------------------------
720 # This subroutine may be overkill. See what is really needed here and remove
723 # Upon return, one directory has been selected to be used in the remainder.
724 # This is not always the correct thing to do, but is the same as the original
725 # code. In due time this should be addressed though.
726 #------------------------------------------------------------------------------
727 ($archive_dir_not_empty, $selected_archive, $elf_rats_ref) =
728 check_validity_exp_dirs
(\
@exp_dir_list);
730 %elf_rats = %{$elf_rats_ref};
732 $msg = "the experiment directories have been verified and are valid";
733 gp_message
("verbose", $subr_name, $msg);
735 #------------------------------------------------------------------------------
736 # Now that we know the map.xml file(s) are present, we can scan these and get
737 # the required information. This includes setting the base virtual address.
738 #------------------------------------------------------------------------------
739 $ignore_value = determine_base_virtual_address
($exp_dir_list_ref);
741 #------------------------------------------------------------------------------
742 # Check whether the experiment directories are consistent.
743 #------------------------------------------------------------------------------
744 ($consistency_errors, $executable_name) =
745 verify_consistency_experiments
($exp_dir_list_ref);
747 if ($consistency_errors == 0)
749 $msg = "the experiment directories are consistent";
750 gp_message
("verbose", $subr_name, $msg);
754 $msg = "the number of consistency errors detected: $consistency_errors";
755 gp_message
("abort", $subr_name, $msg);
758 #------------------------------------------------------------------------------
759 # The directories are consistent. We can now set the base virtual address of
761 #------------------------------------------------------------------------------
762 $base_va_executable =
763 $g_exp_dir_meta_data{$selected_archive}{"va_base_in_hex"};
765 $msg = "executable_name = " . $executable_name;
766 gp_message
("debug", $subr_name, $msg);
767 $msg = "selected_archive = " . $selected_archive;
768 gp_message
("debug", $subr_name, $msg);
769 $msg = "base_va_executable = " . $base_va_executable;
770 gp_message
("debug", $subr_name, $msg);
772 #------------------------------------------------------------------------------
773 # The $GP_DISPLAY_TEXT tool is critical and has to be available in order to
775 # This subroutine only returns a value if the tool can be found.
776 #------------------------------------------------------------------------------
777 $g_path_to_tools = ${ check_availability_tool
(\
$location_gp_command)};
779 $GP_DISPLAY_TEXT = $g_path_to_tools . $GP_DISPLAY_TEXT;
781 $msg = "updated GP_DISPLAY_TEXT = $GP_DISPLAY_TEXT";
782 gp_message
("debug", $subr_name, $msg);
784 #------------------------------------------------------------------------------
785 # Check if $GP_DISPLAY_TEXT is executable for user, group, and other.
786 # If not, print a warning only, since this may not be fatal but could
787 # potentially lead to issues later on.
788 #------------------------------------------------------------------------------
789 if (not is_file_executable
($GP_DISPLAY_TEXT))
791 $msg = "file $GP_DISPLAY_TEXT is not executable for user, group, and";
793 gp_message
("warning", $subr_name, $msg);
796 #------------------------------------------------------------------------------
797 # Find out what the decimal separator is, as set by the user.
798 #------------------------------------------------------------------------------
799 ($return_code, $decimal_separator, $convert_to_dot) =
800 determine_decimal_separator
();
802 if ($return_code == 0)
804 $msg = "decimal separator is $decimal_separator";
805 $msg .= " (conversion to dot is ";
806 $msg .= ($convert_to_dot == $TRUE ?
"enabled" : "disabled") . ")";
807 gp_message
("debugXL", $subr_name, $msg);
811 $msg = "the decimal separator cannot be determined -";
812 $msg .= " set to $decimal_separator";
813 gp_message
("warning", $subr_name, $msg);
816 #------------------------------------------------------------------------------
817 # Collect and store the system information.
818 #------------------------------------------------------------------------------
819 $msg = "collect system information and adapt settings";
820 gp_message
("verbose", $subr_name, $msg);
822 $return_code = get_system_config_info
();
824 #------------------------------------------------------------------------------
825 # The 3 variables below are used in the remainder.
827 # The output from "uname -p" is recommended to be used for the ISA.
828 #------------------------------------------------------------------------------
829 my $hostname_current = $local_system_config{hostname_current
};
830 my $arch_uname_s = $local_system_config{kernel_name
};
831 my $arch_uname = $local_system_config{processor
};
833 gp_message
("debug", $subr_name, "set hostname_current = $hostname_current");
834 gp_message
("debug", $subr_name, "set arch_uname_s = $arch_uname_s");
835 gp_message
("debug", $subr_name, "set arch_uname = $arch_uname");
837 #------------------------------------------------------------------------------
838 # This function also sets the values in "g_arch_specific_settings". This
839 # includes several definitions of regular expressions.
840 #------------------------------------------------------------------------------
841 ($architecture_supported, $elf_arch, $elf_support) =
842 set_system_specific_variables
($arch_uname, $arch_uname_s);
844 $msg = "architecture_supported = $architecture_supported";
845 gp_message
("debug", $subr_name, $msg);
846 $msg = "elf_arch = $elf_arch";
847 gp_message
("debug", $subr_name, $msg);
848 $msg = "elf_support = ".($elf_arch ?
"TRUE" : "FALSE");
849 gp_message
("debug", $subr_name, $msg);
851 for my $feature (sort keys %g_arch_specific_settings)
853 $msg = "g_arch_specific_settings{$feature} = ";
854 $msg .= $g_arch_specific_settings{$feature};
855 gp_message
("debug", $subr_name, $msg);
858 $arch = $g_arch_specific_settings{"arch"};
859 $subexp = $g_arch_specific_settings{"subexp"};
860 $linksubexp = $g_arch_specific_settings{"linksubexp"};
862 $g_locale_settings{"LANG"} = get_LANG_setting
();
864 $msg = "after get_LANG_setting: LANG = $g_locale_settings{'LANG'}";
865 gp_message
("debugXL", $subr_name, $msg);
867 #------------------------------------------------------------------------------
868 # Temporarily reset selected settings since these are not yet implemented.
869 #------------------------------------------------------------------------------
870 $ignore_value = reset_selected_settings
();
872 #------------------------------------------------------------------------------
873 # TBD: Revisit. Is this really necessary?
874 #------------------------------------------------------------------------------
876 ($executable_name, $va_executable_in_hex) =
877 check_loadobjects_are_elf
($selected_archive);
878 $elf_loadobjects_found = $TRUE;
880 # TBD: Hack and those ARCHIVES_ names can be eliminated
881 $ARCHIVES_MAP_NAME = $executable_name;
882 $ARCHIVES_MAP_VADDR = $va_executable_in_hex;
884 $msg = "hack ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME";
885 gp_message
("debugXL", $subr_name, $msg);
886 $msg = "hack ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR";
887 gp_message
("debugXL", $subr_name, $msg);
889 $msg = "after call to check_loadobjects_are_elf forced";
890 $msg .= " elf_loadobjects_found = $elf_loadobjects_found";
891 gp_message
("debugXL", $subr_name, $msg);
893 $g_html_credits_line = ${ create_html_credits
() };
895 $msg = "g_html_credits_line = $g_html_credits_line";
896 gp_message
("debugXL", $subr_name, $msg);
898 #------------------------------------------------------------------------------
899 # Add a "/" to simplify the construction of path names in the remainder.
901 # TBD: Push this into a subroutine(s).
902 #------------------------------------------------------------------------------
903 $outputdir = append_forward_slash
($outputdir);
905 gp_message
("debug", $subr_name, "prepared outputdir = $outputdir");
907 #------------------------------------------------------------------------------
908 #------------------------------------------------------------------------------
909 # ******* TBD: e.system not available on Linux!!
910 #------------------------------------------------------------------------------
911 #------------------------------------------------------------------------------
913 ## my $summary_metrics = 'e.totalcpu';
914 $detail_metrics = 'e.totalcpu';
915 $detail_metrics_system = 'e.totalcpu:e.system';
916 $call_metrics = 'a.totalcpu';
921 my $outfile1 = $outputdir ."metrics";
922 my $outfile2 = $outputdir . "metrictotals";
923 my $gp_error_file = $outputdir . $g_gp_error_logfile;
925 #------------------------------------------------------------------------------
926 # Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is
927 # to get all the output in files $outfile1 and $outfile2. These are then
929 #------------------------------------------------------------------------------
930 $msg = "gather the metrics data from the experiments";
931 gp_message
("verbose", $subr_name, $msg);
933 $return_code = get_metrics_data
(\
@exp_dir_list, $outputdir, $outfile1,
934 $outfile2, $gp_error_file);
936 if ($return_code != 0)
938 gp_message
("abort", $subr_name, "execution terminated");
941 #------------------------------------------------------------------------------
942 # TBD: Test this code
943 #------------------------------------------------------------------------------
944 $msg = "unable to open metric value data file $outfile1 for reading:";
945 open (METRICS
, "<", $outfile1)
946 or die ($subr_name . " - " . $msg . " " . $!);
948 $msg = "opened file $outfile1 for reading";
949 gp_message
("debug", $subr_name, "opened file $outfile1 for reading");
951 chomp (@metrics_data = <METRICS
>);
954 for my $i (keys @metrics_data)
956 $msg = "metrics_data[$i] = " . $metrics_data[$i];
957 gp_message
("debugXL", $subr_name, $msg);
960 #------------------------------------------------------------------------------
961 # Process the generated metrics data.
962 #------------------------------------------------------------------------------
963 if ($g_user_settings{"default_metrics"}{"current_value"} eq "off")
965 #------------------------------------------------------------------------------
966 # The metrics will be derived from the experiments.
967 #------------------------------------------------------------------------------
969 gp_message
("verbose", $subr_name, "Process the metrics data");
971 ($metric_value_ref, $metric_description_ref, $metric_found_ref,
972 $user_metrics, $system_metrics, $wall_metrics,
973 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics
974 ) = process_metrics_data
($outfile1, $outfile2, \
%ignored_metrics);
976 %metric_value = %{ $metric_value_ref };
977 %metric_description = %{ $metric_description_ref };
978 %metric_found = %{ $metric_found_ref };
979 %metric_description_reversed = reverse %metric_description;
981 $msg = "after the call to process_metrics_data";
982 gp_message
("debugXL", $subr_name, $msg);
984 for my $metric (sort keys %metric_value)
986 $msg = "metric_value{$metric} = " . $metric_value{$metric};
987 gp_message
("debugXL", $subr_name, $msg);
989 for my $metric (sort keys %metric_description)
991 $msg = "metric_description{$metric} =";
992 $msg .= " " . $metric_description{$metric};
993 gp_message
("debugXL", $subr_name, $msg);
995 gp_message
("debugXL", $subr_name, "user_metrics = $user_metrics");
996 gp_message
("debugXL", $subr_name, "system_metrics = $system_metrics");
997 gp_message
("debugXL", $subr_name, "wall_metrics = $wall_metrics");
1001 #------------------------------------------------------------------------------
1002 # A default set of metrics will be used.
1004 # TBD: These should be OS dependent.
1005 #------------------------------------------------------------------------------
1006 $msg = "select the set of default metrics";
1007 gp_message
("verbose", $subr_name, $msg);
1009 ($metric_description_ref, $metric_found_ref, $summary_metrics,
1010 $detail_metrics, $detail_metrics_system, $call_metrics
1011 ) = set_default_metrics
($outfile1, \
%ignored_metrics);
1014 %metric_description = %{ $metric_description_ref };
1015 %metric_found = %{ $metric_found_ref };
1016 %metric_description_reversed = reverse %metric_description;
1018 $msg = "after the call to set_default_metrics";
1019 gp_message
("debug", $subr_name, $msg);
1023 $number_of_metrics = split (":", $summary_metrics);
1025 $msg = "summary_metrics = " . $summary_metrics;
1026 gp_message
("debugXL", $subr_name, $msg);
1027 $msg = "detail_metrics = " . $detail_metrics;
1028 gp_message
("debugXL", $subr_name, $msg);
1029 $msg = "detail_metrics_system = " . $detail_metrics_system;
1030 gp_message
("debugXL", $subr_name, $msg);
1031 $msg = "call_metrics = " . $call_metrics;
1032 gp_message
("debugXL", $subr_name, $msg);
1033 $msg = "number_of_metrics = " . $number_of_metrics;
1034 gp_message
("debugXL", $subr_name, $msg);
1036 #------------------------------------------------------------------------------
1037 # TBD Find a way to better handle this situation:
1038 #------------------------------------------------------------------------------
1039 for my $im (keys %metric_found)
1041 $msg = "metric_found{$im} = " . $metric_found{$im};
1042 gp_message
("debugXL", $subr_name, $msg);
1044 for my $im (keys %ignored_metrics)
1046 if (not exists ($metric_found{$im}))
1048 $msg = "user requested ignored metric (-im) $im does not exist in";
1049 $msg .= " collected metrics";
1050 gp_message
("debugXL", $subr_name, $msg);
1054 #------------------------------------------------------------------------------
1055 # Get the information on the experiments.
1056 #------------------------------------------------------------------------------
1057 $msg = "generate the experiment information";
1058 gp_message
("verbose", $subr_name, $msg);
1060 my $experiment_data_ref = get_experiment_info
(\
$outputdir, \
@exp_dir_list);
1061 @experiment_data = @
{ $experiment_data_ref };
1063 for my $i (sort keys @experiment_data)
1065 my $msg = "i = $i " . $experiment_data[$i]{"exp_id"} . " => " .
1066 $experiment_data[$i]{"exp_name_full"};
1067 gp_message
("debugM", $subr_name, $msg);
1070 $experiment_data_ref = process_experiment_info
($experiment_data_ref);
1071 @experiment_data = @
{ $experiment_data_ref };
1073 for my $i (sort keys @experiment_data)
1075 for my $fields (sort keys %{ $experiment_data[$i] })
1077 my $msg = "i = $i experiment_data[$i]{$fields} = " .
1078 $experiment_data[$i]{$fields};
1079 gp_message
("debugXL", $subr_name, $msg);
1083 @g_html_experiment_stats = @
{ create_exp_info
(\
@exp_dir_list,
1084 \
@experiment_data) };
1086 $table_execution_stats_ref = html_generate_exp_summary
(\
$outputdir,
1088 @table_execution_stats = @
{ $table_execution_stats_ref };
1090 #------------------------------------------------------------------------------
1091 # Get the function overview.
1092 #------------------------------------------------------------------------------
1093 $msg = "generate the list with functions executed";
1094 gp_message
("verbose", $subr_name, $msg);
1096 my ($outfile, $sort_fields_ref) =
1097 get_hot_functions
(\
@exp_dir_list, $summary_metrics, $outputdir);
1099 @sort_fields = @
{$sort_fields_ref};
1101 #------------------------------------------------------------------------------
1102 # Parse the output from the fsummary command and store the relevant data for
1103 # all the functions listed there.
1104 #------------------------------------------------------------------------------
1105 $msg = "analyze and store the relevant function information";
1106 gp_message
("verbose", $subr_name, $msg);
1108 ($function_info_ref, $function_address_and_index_ref, $addressobjtextm_ref,
1109 $LINUX_vDSO_ref, $function_view_structure_ref) =
1110 get_function_info
($outfile);
1112 @function_info = @
{ $function_info_ref };
1113 %function_address_and_index = %{ $function_address_and_index_ref };
1114 %addressobjtextm = %{ $addressobjtextm_ref };
1115 %LINUX_vDSO = %{ $LINUX_vDSO_ref };
1116 %function_view_structure = %{ $function_view_structure_ref };
1118 for my $keys (0 .. $#function_info)
1120 for my $fields (keys %{$function_info[$keys]})
1122 $msg = "$keys $fields $function_info[$keys]{$fields}";
1123 gp_message
("debugXL", $subr_name, $msg);
1127 for my $i (keys %addressobjtextm)
1129 $msg = "addressobjtextm{$i} = " . $addressobjtextm{$i};
1130 gp_message
("debugXL", $subr_name, $msg);
1133 $msg = "generate the files with function overviews and the";
1134 $msg .= " callers-callees information";
1135 gp_message
("verbose", $subr_name, $msg);
1137 $script_pc_metrics = generate_function_level_info
(\
@exp_dir_list,
1143 $msg = "preprocess the files with the function level information";
1144 gp_message
("verbose", $subr_name, $msg);
1146 $ignore_value = preprocess_function_files
(
1147 $metric_description_ref,
1152 $msg = "for each function, generate a set of files";
1153 gp_message
("verbose", $subr_name, $msg);
1155 ($function_info_ref, $function_address_info_ref, $addressobj_index_ref) =
1156 process_function_files
(\
@exp_dir_list,
1158 $time_percentage_multiplier,
1160 $process_all_functions,
1161 $elf_loadobjects_found,
1165 \
%function_address_and_index,
1167 \
%metric_description,
1169 $base_va_executable,
1171 $ARCHIVES_MAP_VADDR,
1174 @function_info = @
{ $function_info_ref };
1175 %function_address_info = %{ $function_address_info_ref };
1176 %addressobj_index = %{ $addressobj_index_ref };
1178 #------------------------------------------------------------------------------
1179 # Parse the disassembly information and generate the html files.
1180 #------------------------------------------------------------------------------
1181 $msg = "parse the disassembly files and generate the html files";
1182 gp_message
("verbose", $subr_name, $msg);
1184 $ignore_value = parse_dis_files
(\
$number_of_metrics,
1186 \
%function_address_and_index,
1188 \
%addressobj_index);
1190 #------------------------------------------------------------------------------
1191 # Parse the source information and generate the html files.
1192 #------------------------------------------------------------------------------
1193 $msg = "parse the source files and generate the html files";
1194 gp_message
("verbose", $subr_name, $msg);
1196 parse_source_files
(\
$number_of_metrics, \
@function_info, \
$outputdir);
1198 #------------------------------------------------------------------------------
1199 # Parse the caller-callee information and generate the html files.
1200 #------------------------------------------------------------------------------
1201 $msg = "process the caller-callee information and generate the html file";
1202 gp_message
("verbose", $subr_name, $msg);
1204 #------------------------------------------------------------------------------
1205 # Generate the caller-callee information.
1206 #------------------------------------------------------------------------------
1207 $ignore_value = generate_caller_callee
(\
$number_of_metrics,
1209 \
%function_view_structure,
1210 \
%function_address_info,
1214 #------------------------------------------------------------------------------
1215 # Parse the calltree information and generate the html files.
1216 #------------------------------------------------------------------------------
1217 if ($g_user_settings{"calltree"}{"current_value"} eq "on")
1219 $msg = "process the call tree information and generate the html file";
1220 gp_message
("verbose", $subr_name, $msg);
1222 $ignore_value = process_calltree
(\
@function_info,
1223 \
%function_address_info,
1228 #------------------------------------------------------------------------------
1229 # Process the metric values.
1230 #------------------------------------------------------------------------------
1231 $msg = "generate the html file with the metrics information";
1232 gp_message
("verbose", $subr_name, $msg);
1234 $ignore_value = process_metrics
($outputdir,
1236 \
%metric_description,
1239 #------------------------------------------------------------------------------
1240 # Generate the function view html files.
1241 #------------------------------------------------------------------------------
1242 $msg = "generate the function view html files";
1243 gp_message
("verbose", $subr_name, $msg);
1245 $html_first_metric_file_ref = generate_function_view
(
1248 \
$number_of_metrics,
1250 \
%function_view_structure,
1251 \
%function_address_info,
1256 $html_first_metric_file = ${ $html_first_metric_file_ref };
1258 $msg = "html_first_metric_file = " . $html_first_metric_file;
1259 gp_message
("debugXL", $subr_name, $msg);
1261 $html_test = ${ generate_home_link
("left") };
1262 $msg = "html_test = " . $html_test;
1263 gp_message
("debugXL", $subr_name, $msg);
1265 #------------------------------------------------------------------------------
1266 # Unconditionnaly generate the page with the warnings.
1267 #------------------------------------------------------------------------------
1268 $ignore_value = html_create_warnings_page
(\
$outputdir);
1270 #------------------------------------------------------------------------------
1271 # Generate the index.html file.
1272 #------------------------------------------------------------------------------
1273 $msg = "generate the index.html file";
1274 gp_message
("verbose", $subr_name, $msg);
1276 $ignore_value = html_generate_index
(\
$outputdir,
1277 \
$html_first_metric_file,
1279 \
$number_of_metrics,
1281 \
%function_address_info,
1285 \
%metric_description_reversed,
1286 \
@table_execution_stats);
1288 #------------------------------------------------------------------------------
1289 # We're done. In debug mode, print the meta data for the experiment
1291 #------------------------------------------------------------------------------
1292 $ignore_value = print_meta_data_experiments
("debug");
1294 #------------------------------------------------------------------------------
1295 # Before the execution completes, print the warning(s) on the screen.
1297 # Note that this assumes that no additional warnings have been created since
1298 # the call to html_create_warnings_page. Otherwise there will be a discrepancy
1299 # between what is printed on the screen and shown in the warnings.html page.
1300 #------------------------------------------------------------------------------
1301 if (($g_total_warning_count > 0) and ($g_warnings))
1303 $ignore_value = print_warnings_buffer
();
1304 @g_warning_msgs = ();
1307 #------------------------------------------------------------------------------
1308 # This is not supposed to happen, but in case there are any fatal errors that
1309 # have not caused the execution to terminate, print them here.
1310 #------------------------------------------------------------------------------
1313 $ignore_value = print_errors_buffer
(\
$g_error_keyword);
1316 #------------------------------------------------------------------------------
1317 # One line message to show where the results can be found.
1318 #------------------------------------------------------------------------------
1319 my $results_file = $abs_path_outputdir . "/index.html";
1320 my $prologue_text = "Processing completed - view file $results_file" .
1322 gp_message
("diag", $subr_name, $prologue_text);
1326 } #-- End of subroutine main
1328 #------------------------------------------------------------------------------
1329 # If it is not present, add a "/" to the name of the argument. This is
1330 # intended to be used for the name of the output directory and makes it
1331 # easier to construct pathnames.
1332 #------------------------------------------------------------------------------
1333 sub append_forward_slash
1335 my $subr_name = get_my_name
();
1337 my ($input_string) = @_;
1339 my $length_of_string = length ($input_string);
1340 my $return_string = $input_string;
1342 if (rindex ($input_string, "/") != $length_of_string-1)
1344 $return_string .= "/";
1347 return ($return_string);
1349 } #-- End of subroutine append_forward_slash
1351 #------------------------------------------------------------------------------
1352 # Return a string with a comma separated list of directory names.
1353 #------------------------------------------------------------------------------
1354 sub build_pretty_dir_list
1356 my $subr_name = get_my_name
();
1358 my ($dir_list_ref) = @_;
1360 my @dir_list = @
{ $dir_list_ref};
1362 my $pretty_dir_list = join ("\n", @dir_list);
1364 return ($pretty_dir_list);
1366 } #-- End of subroutine build_pretty_dir_list
1368 #------------------------------------------------------------------------------
1369 # Calculate the target address in hex by adding the instruction to the
1370 # instruction address.
1371 #------------------------------------------------------------------------------
1372 sub calculate_target_hex_address
1374 my $subr_name = get_my_name
();
1376 my ($instruction_address, $instruction_offset) = @_;
1378 my $dec_branch_target;
1382 my $length_of_string;
1385 my $number_of_fields;
1386 my $raw_hex_branch_target;
1389 if ($g_addressing_mode eq "64 bit")
1391 $mask = "0xffffffffffffffff";
1392 $number_of_fields = 16;
1396 $msg = "g_addressing_mode = $g_addressing_mode not supported";
1397 gp_message
("abort", $subr_name, $msg);
1400 $length_of_string = length ($instruction_offset);
1401 $first_char = lcfirst (substr ($instruction_offset,0,1));
1402 $d1 = bigint
::hex ($instruction_offset);
1403 $d2 = bigint
::hex ($mask);
1404 # if ($first_char eq "f")
1405 if (($first_char =~ /[89a-f]/) and ($length_of_string == $number_of_fields))
1407 #------------------------------------------------------------------------------
1408 # The offset is negative. Convert to decimal and perform the subtrraction.
1409 #------------------------------------------------------------------------------
1410 #------------------------------------------------------------------------------
1411 # XOR the decimal representation and add 1 to the result.
1412 #------------------------------------------------------------------------------
1413 $result = ($d1 ^ $d2) + 1;
1414 $dec_branch_target = bigint
::hex ($instruction_address) - $result;
1419 $dec_branch_target = bigint
::hex ($instruction_address) + $result;
1421 #------------------------------------------------------------------------------
1422 # Convert to hexadecimal.
1423 #------------------------------------------------------------------------------
1424 $raw_hex_branch_target = sprintf ("%x", $dec_branch_target);
1426 return ($raw_hex_branch_target);
1428 } #-- End of subroutine calculate_target_hex_address
1430 #------------------------------------------------------------------------------
1431 # Sets the absolute path to all commands in array @cmds.
1433 # First, it is checked if the command is in the search path, built-in, or an
1434 # alias. If this is not the case, search for it in a couple of locations.
1436 # If this all fails, warning messages are printed, but this is not a hard
1437 # error. Yet. Most likely, things will go bad later on.
1439 # The commands and their respective paths are stored in hash "g_mapped_cmds".
1440 #------------------------------------------------------------------------------
1441 sub check_and_define_cmds
1443 my $subr_name = get_my_name
();
1445 my ($cmds_ref, $search_path_ref) = @_;
1447 #------------------------------------------------------------------------------
1448 # Dereference the array addressess first and then store the contents.
1449 #------------------------------------------------------------------------------
1450 my @cmds = @
{$cmds_ref};
1451 my @search_path = @
{$search_path_ref};
1453 my @the_fields = ();
1463 my $no_of_failed_mappings;
1467 my $failed_mapping = $FALSE;
1470 gp_message
("debugXL", $subr_name, "\@cmds = @cmds");
1471 gp_message
("debugXL", $subr_name, "\@search_path = @search_path");
1473 #------------------------------------------------------------------------------
1474 # Search for the command and record the absolute path. In case no such path
1475 # can be found, the entry in $g_mapped_cmds is assigned a special value that
1476 # will be checked for in the next block.
1477 #------------------------------------------------------------------------------
1480 $target_cmd = "(command -v $cmd; echo \$\?)";
1482 ($error_code, $output_cmd) = execute_system_cmd
($target_cmd);
1484 if ($error_code != 0)
1485 #------------------------------------------------------------------------------
1486 # This is unlikely to happen, since it means the command executed failed.
1487 #------------------------------------------------------------------------------
1489 $msg = "error executing this command: " . $target_cmd;
1490 gp_message
("warning", $subr_name, $msg);
1491 $msg = "execution continues, but may fail later on";
1492 gp_message
("warning", $subr_name, $msg);
1494 $g_total_warning_count++;
1497 #------------------------------------------------------------------------------
1498 # So far, all is well, but is the target command available?
1499 #------------------------------------------------------------------------------
1501 #------------------------------------------------------------------------------
1502 # The output from the $target_cmd command should contain 2 lines in case the
1503 # command has been found. The first line shows the command with the full
1504 # path, while the second line has the exit code.
1506 # If the exit code is not zero, the command has not been found.
1507 #------------------------------------------------------------------------------
1509 #------------------------------------------------------------------------------
1510 # Split the output at the \n character and check the number of lines as
1511 # well as the return code.
1512 #------------------------------------------------------------------------------
1513 @the_fields = split ("\n", $output_cmd);
1514 $no_of_fields = scalar (@the_fields);
1515 $cmd_found = ($the_fields[$no_of_fields-1] == 0 ?
$TRUE : $FALSE);
1517 #------------------------------------------------------------------------------
1518 # This is unexpected. Throw an assertion error and bail out.
1519 #------------------------------------------------------------------------------
1520 if ($no_of_fields > 2)
1522 gp_message
("error", $subr_name, "output from $target_cmd:");
1523 gp_message
("error", $subr_name, $output_cmd);
1525 $msg = "the output from $target_cmd has more than 2 lines";
1526 gp_message
("assertion", $subr_name, $msg);
1531 $full_path_cmd = $the_fields[0];
1532 #------------------------------------------------------------------------------
1533 # The command is in the search path. Store the full path to the command.
1534 #------------------------------------------------------------------------------
1535 $msg = "the $cmd command is in the search path";
1536 gp_message
("debug", $subr_name, $msg);
1538 $g_mapped_cmds{$cmd} = $full_path_cmd;
1541 #------------------------------------------------------------------------------
1542 # A best effort to locate the command elsewhere. If found, store the command
1543 # with the absolute path included. Otherwise print a warning, but continue.
1544 #------------------------------------------------------------------------------
1546 $msg = "the $cmd command is not in the search path";
1547 $msg .= " - start a best effort search to find it";
1548 gp_message
("debug", $subr_name, $msg);
1550 $found_match = $FALSE;
1551 for my $path (@search_path)
1553 $target_cmd = $path . "/" . $cmd;
1556 $msg = "found the command in $path";
1557 gp_message
("debug", $subr_name, $msg);
1559 $found_match = $TRUE;
1560 $g_mapped_cmds{$cmd} = $target_cmd;
1565 $msg = "failure to find the $cmd command in $path";
1566 gp_message
("debug", $subr_name, $msg);
1570 if (not $found_match)
1572 $g_mapped_cmds{$cmd} = "road to nowhere";
1573 $failed_mapping = $TRUE;
1579 #------------------------------------------------------------------------------
1580 # Scan the results stored in $g_mapped_cmds and flag errors.
1581 #------------------------------------------------------------------------------
1582 $no_of_failed_mappings = 0;
1585 #------------------------------------------------------------------------------
1586 # Print a warning message before showing the results, that at least one search
1588 #------------------------------------------------------------------------------
1589 if ($failed_mapping)
1591 $msg = "<br>" . "failure in the verification of the OS commands:";
1592 gp_message
("warning", $subr_name, $msg);
1595 while ( ($cmd, $mapped) = each %g_mapped_cmds)
1597 if ($mapped eq "road to nowhere")
1599 $msg = "cannot find a path for command $cmd";
1600 gp_message
("warning", $subr_name, $msg);
1601 gp_message
("debug", $subr_name, $msg);
1603 $no_of_failed_mappings++;
1604 $failed_cmds .= $cmd;
1605 $g_mapped_cmds{$cmd} = $cmd;
1609 $msg = "path for the $cmd command is $mapped";
1610 gp_message
("debug", $subr_name, $msg);
1613 if ($no_of_failed_mappings != 0)
1615 my $plural_1 = ($no_of_failed_mappings > 1) ?
"failures" : "failure";
1616 my $plural_2 = ($no_of_failed_mappings > 1) ?
"commands" : "command";
1618 $msg = "encountered $no_of_failed_mappings $plural_1 to locate";
1619 $msg .= " selected " . $plural_2;
1620 gp_message
("warning", $subr_name, $msg);
1621 gp_message
("debug", $subr_name, $msg);
1623 $msg = "execution continues, but may fail later on";
1624 gp_message
("warning", $subr_name, $msg);
1625 gp_message
("debug", $subr_name, $msg);
1627 $g_total_warning_count++;
1630 return ($no_of_failed_mappings);
1632 } #-- End of subroutine check_and_define_cmds
1634 #------------------------------------------------------------------------------
1635 # Look for a branch instruction, or the special endbr32/endbr64 instruction
1636 # that is also considered to be a branch target. Note that the latter is x86
1638 #------------------------------------------------------------------------------
1639 sub check_and_proc_dis_branches
1641 my $subr_name = get_my_name
();
1643 my ($input_line_ref, $line_no_ref, $branch_target_ref,
1644 $extended_branch_target_ref, $branch_target_no_ref_ref) = @_;
1646 my $input_line = ${ $input_line_ref };
1647 my $line_no = ${ $line_no_ref };
1648 my %branch_target = %{ $branch_target_ref };
1649 my %extended_branch_target = %{ $extended_branch_target_ref };
1650 my %branch_target_no_ref = %{ $branch_target_no_ref_ref };
1652 my $found_it = $TRUE;
1653 my $hex_branch_target;
1654 my $instruction_address;
1655 my $instruction_offset;
1657 my $raw_hex_branch_target;
1659 if ( ($input_line =~ /$g_branch_regex/)
1660 or ($input_line =~ /$g_endbr_regex/))
1664 $msg = "found a branch or endbr instruction: " .
1665 "\$1 = $1 \$2 = $2 \$3 = $3";
1669 $msg = "found a branch or endbr instruction: " .
1670 "\$1 = $1 \$2 = $2";
1672 gp_message
("debugXL", $subr_name, $msg);
1676 #------------------------------------------------------------------------------
1677 # Found a qualifying instruction
1678 #------------------------------------------------------------------------------
1679 $instruction_address = $1;
1682 #------------------------------------------------------------------------------
1683 # This must be the branch target and needs to be converted and processed.
1684 #------------------------------------------------------------------------------
1685 $instruction_offset = $3;
1686 $raw_hex_branch_target = calculate_target_hex_address
(
1687 $instruction_address,
1688 $instruction_offset);
1690 $hex_branch_target = "0x" . $raw_hex_branch_target;
1691 $branch_target{$hex_branch_target} = 1;
1692 $extended_branch_target{$instruction_address} =
1693 $raw_hex_branch_target;
1695 if (defined ($2) and (not defined ($3)))
1697 #------------------------------------------------------------------------------
1698 # Unlike a branch, the endbr32/endbr64 instructions do not have a second field.
1699 #------------------------------------------------------------------------------
1700 my $instruction_name = $2;
1701 if ($instruction_name =~ /$g_endbr_inst_regex/)
1703 my $msg = "found endbr: $instruction_name " .
1704 $instruction_address;
1705 gp_message
("debugXL", $subr_name, $msg);
1706 $raw_hex_branch_target = $instruction_address;
1708 $hex_branch_target = "0x" . $raw_hex_branch_target;
1709 $branch_target_no_ref{$instruction_address} = 1;
1715 #------------------------------------------------------------------------------
1716 # TBD: Perhaps this should be an assertion or alike.
1717 #------------------------------------------------------------------------------
1718 $branch_target{"0x0000"} = $FALSE;
1719 $msg = "cannot determine branch target";
1720 gp_message
("debug", $subr_name, $msg);
1728 return (\
$found_it, \
%branch_target, \
%extended_branch_target,
1729 \
%branch_target_no_ref);
1731 } #-- End of subroutine check_and_proc_dis_branches
1733 #------------------------------------------------------------------------------
1734 # Check an input line from the disassembly file to include a function call.
1735 # If it does, process the line and return the branch target results.
1736 #------------------------------------------------------------------------------
1737 sub check_and_proc_dis_func_call
1739 my $subr_name = get_my_name
();
1741 my ($input_line_ref, $line_no_ref, $branch_target_ref,
1742 $extended_branch_target_ref) = @_;
1744 my $input_line = ${ $input_line_ref };
1745 my $line_no = ${ $line_no_ref };
1746 my %branch_target = %{ $branch_target_ref };
1747 my %extended_branch_target = %{ $extended_branch_target_ref };
1749 my $found_it = $TRUE;
1750 my $hex_branch_target;
1751 my $instruction_address;
1752 my $instruction_offset;
1754 my $raw_hex_branch_target;
1756 if ( $input_line =~ /$g_function_call_v2_regex/ )
1758 $msg = "found a function call - line[$line_no] = $input_line";
1759 gp_message
("debugXL", $subr_name, $msg);
1760 if (not defined ($2))
1762 $msg = "line[$line_no] " .
1763 "an instruction address is expected, but not found";
1764 gp_message
("assertion", $subr_name, $msg);
1768 $instruction_address = $2;
1770 $msg = "instruction_address = $instruction_address";
1771 gp_message
("debugXL", $subr_name, $msg);
1773 if (not defined ($4))
1775 $msg = "line[$line_no] " .
1776 "an address offset is expected, but not found";
1777 gp_message
("assertion", $subr_name, $msg);
1781 $instruction_offset = $4;
1782 if ($instruction_offset =~ /[0-9a-fA-F]+/)
1784 $msg = "calculate branch target: " .
1785 "instruction_address = $instruction_address";
1786 gp_message
("debugXL", $subr_name, $msg);
1787 $msg = "calculate branch target: " .
1788 "instruction_offset = $instruction_offset";
1789 gp_message
("debugXL", $subr_name, $msg);
1791 #------------------------------------------------------------------------------
1792 # The instruction offset needs to be converted and added to the instruction
1794 #------------------------------------------------------------------------------
1795 $raw_hex_branch_target = calculate_target_hex_address
(
1796 $instruction_address,
1797 $instruction_offset);
1798 $hex_branch_target = "0x" . $raw_hex_branch_target;
1800 $msg = "calculated hex_branch_target = " .
1802 gp_message
("debugXL", $subr_name, $msg);
1804 $branch_target{$hex_branch_target} = 1;
1805 $extended_branch_target{$instruction_address} =
1806 $raw_hex_branch_target;
1808 $msg = "set branch_target{$hex_branch_target} to 1";
1809 gp_message
("debugXL", $subr_name, $msg);
1810 $msg = "added extended_branch_target{$instruction_address}";
1811 $msg .= " = $extended_branch_target{$instruction_address}";
1812 gp_message
("debugXL", $subr_name, $msg);
1816 $msg = "line[$line_no] unknown address format";
1817 gp_message
("assertion", $subr_name, $msg);
1827 return (\
$found_it, \
%branch_target, \
%extended_branch_target);
1829 } #-- End of subroutine check_and_proc_dis_func_call
1831 #------------------------------------------------------------------------------
1832 # Check if the value for the user option given is valid.
1834 # In case the value is valid, the g_user_settings table is updated with the
1837 # Otherwise an error message is pushed into the g_error_msgs buffer.
1839 # The return value is TRUE/FALSE.
1840 #------------------------------------------------------------------------------
1841 sub check_and_set_user_option
1843 my $subr_name = get_my_name
();
1845 my ($internal_opt_name, $value) = @_;
1849 my $option_value_missing;
1851 my $option = $g_user_settings{$internal_opt_name}{"option"};
1852 my $data_type = $g_user_settings{$internal_opt_name}{"data_type"};
1853 my $no_of_args = $g_user_settings{$internal_opt_name}{"no_of_arguments"};
1855 if (($no_of_args >= 1) and
1856 ((not defined ($value)) or (length ($value) == 0)))
1857 #------------------------------------------------------------------------------
1858 # If there was no value given, but it is required, flag an error.
1859 # There could also be a value, but it might be the empty string.
1861 # Note that that there are currently no options with multiple values. Should
1862 # these be introduced, the current check may need to be refined.
1863 #------------------------------------------------------------------------------
1866 $option_value_missing = $TRUE;
1868 elsif ($no_of_args >= 1)
1870 $option_value_missing = $FALSE;
1871 #------------------------------------------------------------------------------
1872 # There is an input value. Check if it is valid and if so, store it.
1874 # Note that we allow the options to be case insensitive.
1875 #------------------------------------------------------------------------------
1876 $valid = verify_if_input_is_valid
($value, $data_type);
1880 if (($data_type eq "onoff") or ($data_type eq "size"))
1882 $g_user_settings{$internal_opt_name}{"current_value"} =
1887 $g_user_settings{$internal_opt_name}{"current_value"} = $value;
1889 $g_user_settings{$internal_opt_name}{"defined"} = $TRUE;
1893 return (\
$valid, \
$option_value_missing);
1895 } #-- End of subroutine check_and_set_user_option
1897 #------------------------------------------------------------------------------
1898 # Check for the $GP_DISPLAY_TEXT tool to be available. This is a critical tool
1899 # needed to provide the information. If it can not be found, execution is
1902 # We first search for this tool in the current execution directory. If it
1903 # cannot be found there, use $PATH to try to locate it.
1904 #------------------------------------------------------------------------------
1905 sub check_availability_tool
1907 my $subr_name = get_my_name
();
1909 my ($location_gp_command_ref) = @_;
1915 my $output_which_gp_display_text;
1919 #------------------------------------------------------------------------------
1920 # Get the path to gp-display-text.
1921 #------------------------------------------------------------------------------
1922 my ($error_occurred_ref, $gp_path_ref, $return_value_ref) =
1923 find_path_to_gp_display_text
($location_gp_command_ref);
1925 $error_occurred = ${ $error_occurred_ref};
1926 $gp_path = ${ $gp_path_ref };
1927 $return_value = ${ $return_value_ref};
1929 $msg = "error_occurred = $error_occurred return_value = $return_value";
1930 gp_message
("debugXL", $subr_name, $msg);
1932 if (not $error_occurred)
1933 #------------------------------------------------------------------------------
1934 # All is well and gp-display-text has been located.
1935 #------------------------------------------------------------------------------
1937 $g_path_to_tools = $return_value;
1939 $msg = "located $GP_DISPLAY_TEXT in the execution directory";
1940 gp_message
("debug", $subr_name, $msg);
1941 $msg = "g_path_to_tools = $g_path_to_tools";
1942 gp_message
("debug", $subr_name, $msg);
1945 #------------------------------------------------------------------------------
1946 # Something went wrong, but perhaps we can still continue. Try to find
1947 # $GP_DISPLAY_TEXT through the search path.
1948 #------------------------------------------------------------------------------
1950 $msg = $g_html_new_line;
1951 $msg .= "could not find $GP_DISPLAY_TEXT in directory $gp_path :";
1952 $msg .= " $return_value";
1953 gp_message
("warning", $subr_name, $msg);
1955 #------------------------------------------------------------------------------
1956 # Check if we can find $GP_DISPLAY_TEXT in the search path.
1957 #------------------------------------------------------------------------------
1958 $msg = "check for $GP_DISPLAY_TEXT to be in the search path";
1959 gp_message
("debug", $subr_name, $msg);
1961 gp_message
("warning", $subr_name, $msg);
1962 $g_total_warning_count++;
1964 $target_cmd = $g_mapped_cmds{"which"} . " $GP_DISPLAY_TEXT 2>&1";
1966 ($error_code, $output_which_gp_display_text) =
1967 execute_system_cmd
($target_cmd);
1969 if ($error_code == 0)
1971 my ($gp_file_name, $gp_path, $suffix_not_used) =
1972 fileparse
($output_which_gp_display_text);
1973 $g_path_to_tools = $gp_path;
1975 $msg = "located $GP_DISPLAY_TEXT in $g_path_to_tools";
1976 gp_message
("warning", $subr_name, $msg);
1977 $msg = "this is the version that will be used";
1978 gp_message
("warning", $subr_name, $msg);
1980 $msg = "the $GP_DISPLAY_TEXT tool is in the search path";
1981 gp_message
("debug", $subr_name, $msg);
1982 $msg = "g_path_to_tools = $g_path_to_tools";
1983 gp_message
("debug", $subr_name, $msg);
1987 $msg = "failure to find $GP_DISPLAY_TEXT in the search path";
1988 gp_message
("error", $subr_name, $msg);
1990 $g_total_error_count++;
1992 gp_message
("abort", $subr_name, $g_abort_msg);
1996 return (\
$g_path_to_tools);
1998 } #-- End of subroutine check_availability_tool
2000 #------------------------------------------------------------------------------
2001 # This function determines whether load objects are in ELF format.
2003 # Compared to the original code, any input value other than 2 or 3 is rejected
2004 # upfront. This not only reduces the nesting level, but also eliminates a
2007 # Also, by isolating the tests for the input files, another nesting level could
2008 # be eliminated, further simplifying this still too complex code.
2009 #------------------------------------------------------------------------------
2010 sub check_loadobjects_are_elf
2012 my $subr_name = get_my_name
();
2014 my ($selected_archive) = @_;
2016 my $event_kind_map_regex;
2017 $event_kind_map_regex = '^<event kind="map"\s.*vaddr=';
2018 $event_kind_map_regex .= '"0x([0-9a-fA-F]+)"\s+.*foffset=';
2019 $event_kind_map_regex .= '"\+*0x([0-9a-fA-F]+)"\s.*modes=';
2020 $event_kind_map_regex .= '"0x([0-9]+)"\s.*name="(.*)".*>$';
2022 my $hostname_current = $local_system_config{"hostname_current"};
2023 my $arch = $local_system_config{"processor"};
2024 my $arch_uname_s = $local_system_config{"kernel_name"};
2026 my $extracted_information;
2028 my $elf_magic_number;
2030 my $executable_name;
2031 my $va_executable_in_hex;
2049 my $path_to_map_file;
2050 my $path_to_log_file;
2052 #------------------------------------------------------------------------------
2053 # TBD: Parameterize and should be the first experiment directory from the list.
2054 #------------------------------------------------------------------------------
2056 $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
2057 $path_to_log_file .= $selected_archive;
2058 $path_to_log_file .= "/log.xml";
2060 gp_message
("debug", $subr_name, "hostname_current = $hostname_current");
2061 gp_message
("debug", $subr_name, "arch = $arch");
2062 gp_message
("debug", $subr_name, "arch_uname_s = $arch_uname_s");
2064 #------------------------------------------------------------------------------
2067 # This check can probably be removed since the presence of the log.xml file is
2068 # checked for in an earlier phase.
2069 #------------------------------------------------------------------------------
2070 $msg = " - unable to open file $path_to_log_file for reading:";
2071 open (LOG_XML
, "<", $path_to_log_file)
2072 or die ($subr_name . $msg . " " . $!);
2074 $msg = "opened file $path_to_log_file for reading";
2075 gp_message
("debug", $subr_name, $msg);
2081 gp_message
("debugM", $subr_name, "read line: $line");
2082 #------------------------------------------------------------------------------
2083 # Search for the first line starting with "<system". Bail out if found and
2084 # parsed. These are two examples:
2085 # <system hostname="ruud-vm" arch="x86_64" \
2086 # os="Linux 4.14.35-2025.400.8.el7uek.x86_64" pagesz="4096" npages="30871514">
2087 #------------------------------------------------------------------------------
2088 if ($line =~ /^\s*<system\s+/)
2090 $msg = "selected the following line from the log.xml file:";
2091 gp_message
("debugM", $subr_name, $msg);
2092 gp_message
("debugM", $subr_name, "$line");
2093 if ($line =~ /.*\s+hostname="([^"]+)/)
2096 $msg = "extracted hostname_exp = " . $hostname_exp;
2097 gp_message
("debugM", $subr_name, $msg);
2099 if ($line =~ /.*\s+arch="([^"]+)/)
2102 $msg = "extracted arch_exp = " . $arch_exp;
2103 gp_message
("debugM", $subr_name, $msg);
2105 if ($line =~ /.*\s+os="([^"]+)/)
2108 #------------------------------------------------------------------------------
2109 # Capture the first word only.
2110 #------------------------------------------------------------------------------
2111 if ($os_exp_full =~ /([^\s]+)/)
2115 $msg = "extracted os_exp = " . $os_exp;
2116 gp_message
("debugM", $subr_name, $msg);
2120 } #-- End of while loop
2124 #------------------------------------------------------------------------------
2125 # If the current system is identical to the system used in the experiment,
2126 # we can return early. Otherwise we need to dig deeper.
2128 # TBD: How about the other experiment directories?! This needs to be fixed.
2129 #------------------------------------------------------------------------------
2131 gp_message
("debug", $subr_name, "completed while loop");
2132 gp_message
("debug", $subr_name, "hostname_exp = $hostname_exp");
2133 gp_message
("debug", $subr_name, "arch_exp = $arch_exp");
2134 gp_message
("debug", $subr_name, "os_exp = $os_exp");
2136 #TBD: THIS DOES NOT CHECK IF ELF IS FOUND!
2138 if (($hostname_current eq $hostname_exp) and
2139 ($arch eq $arch_exp) and
2140 ($arch_uname_s eq $os_exp))
2142 $msg = "early return: the hostname, architecture and OS match";
2143 $msg .= " the current system";
2144 gp_message
("debug", $subr_name, $msg);
2145 $msg = "FAKE THIS IS NOT THE CASE AND CONTINUE";
2146 gp_message
("debug", $subr_name, $msg);
2147 # FAKE return ($TRUE);
2150 if (not $g_exp_dir_meta_data{$selected_archive}{"archive_is_empty"})
2152 $msg = "selected_archive = " . $selected_archive;
2153 gp_message
("debug", $subr_name, $msg);
2154 for my $i (sort keys
2155 %{$g_exp_dir_meta_data{$selected_archive}{"archive_files"}})
2157 $msg = "stored loadobject " . $i . " ";
2158 $msg .= $g_exp_dir_meta_data{$selected_archive}{"archive_files"}{$i};
2159 gp_message
("debug", $subr_name, $msg);
2163 #------------------------------------------------------------------------------
2164 # Check if the selected experiment directory has archived files in ELF format.
2165 # If not, use the information in map.xml to get the name of the executable
2166 # and the virtual address.
2167 #------------------------------------------------------------------------------
2169 if ($g_exp_dir_meta_data{$selected_archive}{"archive_in_elf_format"})
2171 $msg = "the files in directory $selected_archive/archives are in";
2172 $msg .= " ELF format";
2173 gp_message
("debugM", $subr_name, $msg);
2174 $msg = "IGNORE THIS AND USE MAP.XML";
2175 gp_message
("debugM", $subr_name, $msg);
2179 $msg = "the files in directory $selected_archive/archives are not in";
2180 $msg .= " ELF format";
2181 gp_message
("debug", $subr_name, $msg);
2184 $g_exp_dir_meta_data{$selected_archive}{"directory_path"};
2185 $path_to_map_file .= $selected_archive;
2186 $path_to_map_file .= "/map.xml";
2188 $msg = " - unable to open file $path_to_map_file for reading:";
2189 open (MAP_XML
, "<", $path_to_map_file)
2190 or die ($subr_name . $msg . " " . $!);
2191 $msg = "opened file $path_to_map_file for reading";
2192 gp_message
("debug", $subr_name, $msg);
2194 #------------------------------------------------------------------------------
2195 # Scan the map.xml file. We need to find the name of the executable with the
2196 # mode set to 0x005. For this entry we have to capture the virtual address.
2197 #------------------------------------------------------------------------------
2198 $extracted_information = $FALSE;
2203 gp_message
("debugM", $subr_name, "MAP_XML read line = $line");
2204 #------------------------------------------------------------------------------
2205 # Replaces this way too long line:
2206 # if ($line =~ /^<event kind="map"\s.*vaddr="0x([0-9a-fA-F]+)"\s+.
2207 # *foffset="\+*0x([0-9a-fA-F]+)"\s.*modes="0x([0-9]+)"\s.*
2209 #------------------------------------------------------------------------------
2210 if ($line =~ /$event_kind_map_regex/)
2212 gp_message
("debugM", $subr_name, "target line = $line");
2217 $name = get_basename
($name_path);
2218 $msg = "extracted vaddr = $vaddr foffset = $foffset";
2219 $msg .= " modes = $modes";
2220 gp_message
("debugM", $subr_name, $msg);
2221 $msg = "extracted name_path = $name_path name = $name";
2222 gp_message
("debugM", $subr_name, $msg);
2223 # $error_extracting_information = $TRUE;
2224 $executable_name = $name;
2225 my $result_VA = bigint
::hex ($vaddr) - bigint
::hex ($foffset);
2226 my $hex_VA = sprintf ("0x%016x", $result_VA);
2227 $va_executable_in_hex = $hex_VA;
2229 $msg = "set executable_name = " . $executable_name;
2230 gp_message
("debugM", $subr_name, $msg);
2231 $msg = "set va_executable_in_hex = " . $va_executable_in_hex;
2232 gp_message
("debugM", $subr_name, $msg);
2233 $msg = "result_VA = " . $result_VA;
2234 gp_message
("debugM", $subr_name, $msg);
2235 $msg = "hex_VA = " . $hex_VA;
2236 gp_message
("debugM", $subr_name, $msg);
2238 if ($modes eq "005")
2240 $extracted_information = $TRUE;
2248 if (not $extracted_information)
2250 $msg = "cannot find the necessary information in";
2251 $msg .= " the $path_to_map_file file";
2252 gp_message
("assertion", $subr_name, $msg);
2255 ## $executable_name = $ARCHIVES_MAP_NAME;
2256 ## $va_executable_in_hex = $ARCHIVES_MAP_VADDR;
2258 return ($executable_name, $va_executable_in_hex);
2260 } #-- End of subroutine check_loadobjects_are_elf
2262 #------------------------------------------------------------------------------
2263 # Compare the current metric values against the maximum values. Mark the line
2264 # if a value is within the percentage defined by $hp_value.
2265 #------------------------------------------------------------------------------
2266 sub check_metric_values
2268 my $subr_name = get_my_name
();
2270 my ($metric_values, $max_metric_values_ref) = @_;
2272 my @max_metric_values = @
{ $max_metric_values_ref };
2274 my @current_metrics = ();
2275 my $colour_coded_line;
2277 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
2280 my $relative_distance;
2282 @current_metrics = split (" ", $metric_values);
2283 $colour_coded_line = $FALSE;
2285 for my $metric (0 .. $#current_metrics)
2287 $current_value = $current_metrics[$metric];
2288 if (exists ($max_metric_values[$metric]))
2290 $max_value = $max_metric_values[$metric];
2292 $msg = "metric = $metric current_value = $current_value";
2293 $msg .= " max_value = $max_value";
2294 gp_message
("debugXL", $subr_name, $msg);
2296 if ( ($max_value > 0) and ($current_value > 0) and
2297 ($current_value != $max_value) )
2300 $msg = "metric = $metric current_value = $current_value";
2301 $msg .= " max_value = $max_value";
2302 gp_message
("debugXL", $subr_name, $msg);
2304 $relative_distance = 1.00 - abs (
2305 ($max_value - $current_value)/$max_value );
2307 $msg = "relative_distance = $relative_distance";
2308 gp_message
("debugXL", $subr_name, $msg);
2310 if ($relative_distance >= $hp_value/100.0)
2312 $msg = "metric $metric is within the relative_distance";
2313 gp_message
("debugXL", $subr_name, $msg);
2315 $colour_coded_line = $TRUE;
2320 } #-- End of loop over metrics
2322 return (\
$colour_coded_line);
2324 } #-- End of subroutine check_metric_values
2326 #------------------------------------------------------------------------------
2327 # Check if the system is supported.
2328 #------------------------------------------------------------------------------
2329 sub check_support_for_processor
2331 my $subr_name = get_my_name
();
2333 my ($machine_ref) = @_;
2335 my $machine = ${ $machine_ref };
2338 if ($machine eq "x86_64")
2340 $is_supported = $TRUE;
2344 $is_supported = $FALSE;
2347 return (\
$is_supported);
2349 } #-- End of subroutine check_support_for_processor
2351 #------------------------------------------------------------------------------
2352 # Check the command line options for the occurrence of experiments and make
2353 # sure that this list is contigious. No other names are allowed in this list.
2355 # Terminate execution in case of an error. Otherwise remove the experiment
2356 # names for ARGV (to make the subsequent parsing easier), and return an array
2357 # with the experiment names.
2359 # The following patterns are supposed to be detected:
2361 # <expdir_1> some other word(s) <expdir_2>
2362 # <expdir> some other word(s)
2363 #------------------------------------------------------------------------------
2364 sub check_the_experiment_list
2366 my $subr_name = get_my_name
();
2368 #------------------------------------------------------------------------------
2369 # The name of an experiment directory can contain any non-whitespace
2370 # character(s), but has to end with .er, or optionally .er/. Multiple
2371 # forward slashes are allowed.
2372 #------------------------------------------------------------------------------
2373 my $exp_dir_regex = '^(\S+)(\.er)\/*$';
2374 my $forward_slash_regex = '\/*$';
2377 my @exp_dir_list = ();
2378 my $found_experiment = $FALSE;
2379 my $found_non_exp = $FALSE;
2381 my $name_non_exp_dir = "";
2382 my $no_of_experiments = 0;
2383 my $no_of_invalid_dirs = 0;
2387 for my $i (keys @ARGV)
2389 $current_value = $ARGV[$i];
2390 if ($current_value =~ /$exp_dir_regex/)
2391 #------------------------------------------------------------------------------
2392 # The current value is an experiment. Remove any trailing forward slashes,
2393 # Increment the count, push the value into the array and set the
2394 # found_experiment flag to TRUE.
2395 #------------------------------------------------------------------------------
2397 $no_of_experiments += 1;
2399 $current_value =~ s/$forward_slash_regex//;
2400 push (@exp_dir_list, $current_value);
2402 if (not $found_experiment)
2403 #------------------------------------------------------------------------------
2404 # Start checking for the next field(s).
2405 #------------------------------------------------------------------------------
2407 $found_experiment = $TRUE;
2409 #------------------------------------------------------------------------------
2410 # We had found non-experiment names and now see another experiment. Time to
2411 # bail out of the loop.
2412 #------------------------------------------------------------------------------
2420 if ($found_experiment)
2421 #------------------------------------------------------------------------------
2422 # The current value is not an experiment, but the value of found_experiment
2423 # indicates at least one experiment has been seen already. This means that
2424 # the list of experiment names is not contiguous and that is a fatal error.
2425 #------------------------------------------------------------------------------
2427 $name_non_exp_dir .= $current_value . " ";
2428 $found_non_exp = $TRUE;
2434 #------------------------------------------------------------------------------
2435 #------------------------------------------------------------------------------
2437 #------------------------------------------------------------------------------
2438 #------------------------------------------------------------------------------
2441 #------------------------------------------------------------------------------
2442 # The experiment list is not contiguous.
2443 #------------------------------------------------------------------------------
2446 $msg = "the list with the experiments is not contiguous:";
2447 gp_message
("error", $subr_name, $msg);
2449 $msg = "\"" . $name_non_exp_dir. "\"". " is not an experiment, but" .
2450 " appears in a list where experiments are expected";
2451 gp_message
("error", $subr_name, $msg);
2453 $g_total_error_count++;
2456 if ($no_of_experiments == 0)
2457 #------------------------------------------------------------------------------
2458 # The experiment list is empty.
2459 #------------------------------------------------------------------------------
2462 $msg = "the experiment list is missing from the options";
2463 gp_message
("error", $subr_name, $msg);
2465 $g_total_error_count++;
2469 #------------------------------------------------------------------------------
2470 # If an error has occurred, print the error(s) and terminate execution.
2471 #------------------------------------------------------------------------------
2473 gp_message
("abort", $subr_name, $g_abort_msg);
2476 #------------------------------------------------------------------------------
2477 # We now have a list with experiments, but we still need to verify whether they
2478 # exist, and if so, are these valid experiments?
2479 #------------------------------------------------------------------------------
2480 for my $exp_dir (@exp_dir_list)
2482 $msg = "checking experiment directory $exp_dir";
2483 gp_message
("debug", $subr_name, $msg);
2487 $msg = "directory $exp_dir found";
2488 gp_message
("debug", $subr_name, $msg);
2489 #------------------------------------------------------------------------------
2490 # Files log.xml and map.xml have to be there.
2491 #------------------------------------------------------------------------------
2492 if ((-e
$exp_dir."/log.xml") and (-e
$exp_dir."/map.xml"))
2494 $msg = "directory $exp_dir appears to be a valid experiment";
2495 $msg .= " directory";
2496 gp_message
("debug", $subr_name, $msg);
2500 $no_of_invalid_dirs++;
2501 $msg = "file " . $exp_dir . "/log.xml and/or " . $exp_dir;
2502 $msg .= "/map.xml missing";
2503 gp_message
("debug", $subr_name, $msg);
2505 $msg = "directory " . get_basename
($exp_dir) . " does not";
2506 $msg .= " appear to be a valid experiment directory";
2507 gp_message
("error", $subr_name, $msg);
2509 $g_total_error_count++;
2514 $no_of_invalid_dirs++;
2515 $msg = "directory " . get_basename
($exp_dir) . " does not exist";
2516 gp_message
("error", $subr_name, $msg);
2518 $g_total_error_count++;
2522 if ($no_of_invalid_dirs > 0)
2523 #------------------------------------------------------------------------------
2524 # This is a fatal error, but for now, we can continue to check for more errors.
2525 # Even if none more are found, execution is terminated before the data is
2526 # generated and processed. In this way we can catch as many errors as
2528 #------------------------------------------------------------------------------
2530 my $plural_or_single = ($no_of_invalid_dirs == 1) ?
2531 "one experiment is" : $no_of_invalid_dirs . " experiments are";
2533 $msg = $plural_or_single . " not valid";
2534 ## gp_message ("abort", $subr_name, $msg);
2536 ## $g_total_error_count++;
2539 #------------------------------------------------------------------------------
2540 # Remove the experiments from ARGV and return the array with the experiment
2541 # names. Note that these may, or may not be valid, but if invalid, execution
2542 # terminates before they are used.
2543 #------------------------------------------------------------------------------
2544 for my $i (1 .. $no_of_experiments)
2546 my $poppy = pop (@ARGV);
2548 $msg = "popped $poppy from ARGV";
2549 gp_message
("debug", $subr_name, $msg);
2551 $msg = "ARGV after update = " . join (" ", @ARGV);
2552 gp_message
("debug", $subr_name, $msg);
2555 return (\
@exp_dir_list);
2557 } #-- End of subroutine check_the_experiment_list
2559 #------------------------------------------------------------------------------
2560 # Perform multiple checks on the experiment directories.
2562 # TBD: It needs to be investigated whether all of this is really neccesary.
2563 #------------------------------------------------------------------------------
2564 sub check_validity_exp_dirs
2566 my $subr_name = get_my_name
();
2568 my ($exp_dir_list_ref) = @_;
2570 my @exp_dir_list = @
{ $exp_dir_list_ref };
2574 my $dir_not_found = $FALSE;
2575 my $missing_dirs = 0;
2576 my $invalid_dirs = 0;
2578 my $archive_dir_not_empty;
2581 my $count_exp_dir_not_elf;
2582 my $elf_magic_number;
2591 my $selected_archive_has_elf_format;
2593 my $selected_archive;
2594 my $archive_dir_selected;
2595 my $no_of_files_in_selected_archive;
2597 #------------------------------------------------------------------------------
2598 # Initialize ELF status to FALSE.
2599 #------------------------------------------------------------------------------
2600 ## for my $exp_dir (@exp_dir_list)
2601 for my $exp_dir (keys %g_exp_dir_meta_data)
2603 $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $FALSE;
2604 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
2606 #------------------------------------------------------------------------------
2607 # Check if the load objects are in ELF format.
2608 #------------------------------------------------------------------------------
2609 for my $exp_dir (keys %g_exp_dir_meta_data)
2611 $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
2612 $archives_dir .= $exp_dir . "/archives";
2613 $archive_dir_not_empty = $FALSE;
2614 $first_time = $TRUE;
2615 $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $TRUE;
2616 $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"} = 0;
2618 $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = ";
2619 $msg .= $g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'};
2620 gp_message
("debug", $subr_name, $msg);
2622 $msg = "checking $archives_dir";
2623 gp_message
("debug", $subr_name, $msg);
2625 while (glob ("$archives_dir/*"))
2627 $filename = get_basename
($_);
2629 $msg = "processing file: $filename";
2630 gp_message
("debug", $subr_name, $msg);
2632 $g_exp_dir_meta_data{$exp_dir}{"archive_files"}{$filename} = $TRUE;
2633 $g_exp_dir_meta_data{$exp_dir}{"no_of_files_in_archive"}++;
2635 $archive_dir_not_empty = $TRUE;
2636 #------------------------------------------------------------------------------
2637 # Replaces the ELF_RATS part in elf_phdr.
2639 # Challenge: splittable_mrg.c_I0txnOW_Wn5
2641 # TBD: Store this for each relevant experiment directory.
2642 #------------------------------------------------------------------------------
2643 my $last_dot = rindex ($filename,".");
2644 my $underscore_before_dot = $TRUE;
2645 my $first_underscore = -1;
2647 $msg = "last_dot = $last_dot";
2648 gp_message
("debugXL", $subr_name, $msg);
2650 while ($underscore_before_dot)
2652 $first_underscore = index ($filename, "_", $first_underscore+1);
2653 if ($last_dot < $first_underscore)
2655 $underscore_before_dot = $FALSE;
2658 my $original_name = substr ($filename, 0, $first_underscore);
2659 $msg = "stripped archive name: " . $original_name;
2660 gp_message
("debug", $subr_name, $msg);
2661 if (not exists ($elf_rats{$original_name}))
2663 $elf_rats{$original_name} = [$filename, $exp_dir];
2665 #------------------------------------------------------------------------------
2666 # We only need to detect the presence of an object once.
2667 #------------------------------------------------------------------------------
2670 $first_time = $FALSE;
2671 $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"} = $FALSE;
2672 $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'} = ";
2673 $msg .= $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
2675 gp_message
("debugXL", $subr_name, $msg);
2678 } #-- End of loop over experiment directories
2680 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2682 my $empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
2683 $msg = "archive directory " . $exp_dir . "/archives is";
2684 $msg .= " " . ($empty ?
"empty" : "not empty");
2685 gp_message
("debug", $subr_name, $msg);
2688 #------------------------------------------------------------------------------
2689 # Verify that all relevant files in the archive directories are in ELF format.
2690 #------------------------------------------------------------------------------
2691 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2693 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} = $FALSE;
2694 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
2696 $archives_dir = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
2697 $archives_dir .= $exp_dir . "/archives";
2698 $msg = "exp_dir = " . $exp_dir . " archives_dir = " . $archives_dir;
2699 gp_message
("debug", $subr_name, $msg);
2700 #------------------------------------------------------------------------------
2701 # Check if any of the loadobjects is of type ELF. Bail out on the first one
2702 # found. The assumption is that all other loadobjects must be of type ELF too
2704 #------------------------------------------------------------------------------
2705 for my $aname (sort keys
2706 %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}})
2708 $filename = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
2709 $filename .= $exp_dir . "/archives/" . $aname;
2710 $msg = " - unable to open file $filename for reading:";
2711 open (ARCF
,"<", $filename)
2712 or die ($subr_name . $msg . " " . $!);
2714 $first_line = <ARCF
>;
2717 #------------------------------------------------------------------------------
2718 # The first 4 hex fields in the header of an ELF file are: 7F 45 4c 46 (7FELF).
2720 # See also https://en.wikipedia.org/wiki/Executable_and_Linkable_Format
2721 #------------------------------------------------------------------------------
2722 # if ($first_line =~ /^\177ELF.*/)
2724 $elf_magic_number = unpack ('H8', $first_line);
2725 if ($elf_magic_number eq "7f454c46")
2727 $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"} =
2729 $g_exp_dir_meta_data{$exp_dir}{"elf_format"} = $TRUE;
2736 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2738 $msg = "the loadobjects in the archive in $exp_dir are";
2739 $msg .= ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ?
2741 $msg .= " ELF format";
2742 gp_message
("debug", $subr_name, $msg);
2744 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2746 if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
2748 $msg = "there are no archived files in " . $exp_dir;
2749 gp_message
("debug", $subr_name, $msg);
2753 #------------------------------------------------------------------------------
2754 # If there are archived files and they are not in ELF format, a debug message
2758 #------------------------------------------------------------------------------
2759 $count_exp_dir_not_elf = 0;
2760 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2762 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"})
2764 $count_exp_dir_not_elf++;
2767 if ($count_exp_dir_not_elf != 0)
2769 $msg = "there are $count_exp_dir_not_elf experiments with non-ELF";
2770 $msg .= " load objects";
2771 gp_message
("debug", $subr_name, $msg);
2774 #------------------------------------------------------------------------------
2775 # Select the experiment directory that is used for the files in the archive.
2776 # By default, a directory with archived files is used, but in case this does
2777 # not exist, a directory without archived files is selected. Obviously this
2778 # needs to be dealt with later on.
2779 #------------------------------------------------------------------------------
2781 #------------------------------------------------------------------------------
2782 # Try the experiments with archived files first.
2783 #------------------------------------------------------------------------------
2784 $archive_dir_not_empty = $FALSE;
2785 $archive_dir_selected = $FALSE;
2786 ## for my $exp_dir (sort @exp_dir_list)
2787 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2789 $msg = "exp_dir = " . $exp_dir;
2790 gp_message
("debugXL", $subr_name, $msg);
2791 $msg = "g_exp_dir_meta_data{$exp_dir}{'archive_is_empty'}";
2792 $msg .= " = " . $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
2793 gp_message
("debugXL", $subr_name, $msg);
2795 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
2797 $selected_archive = $exp_dir;
2798 $archive_dir_not_empty = $TRUE;
2799 $archive_dir_selected = $TRUE;
2800 $selected_archive_has_elf_format =
2801 ($g_exp_dir_meta_data{$exp_dir}{"archive_in_elf_format"}) ?
2806 if (not $archive_dir_selected)
2807 #------------------------------------------------------------------------------
2808 # None are found and pick the first one without archived files.
2809 #------------------------------------------------------------------------------
2811 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2813 if ($g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
2815 $selected_archive = $exp_dir;
2816 $archive_dir_not_empty = $FALSE;
2817 $archive_dir_selected = $TRUE;
2818 $selected_archive_has_elf_format = $FALSE;
2824 $msg = "experiment $selected_archive has been selected for";
2825 $msg .= " archive analysis";
2826 gp_message
("debug", $subr_name, $msg);
2827 $msg = "this archive is";
2828 $msg .= $archive_dir_not_empty ?
" not empty" : " empty";
2829 gp_message
("debug", $subr_name, $msg);
2830 $msg = "this archive is";
2831 $msg .= $selected_archive_has_elf_format ?
" in" : " not in";
2832 $msg .= " ELF format";
2833 gp_message
("debug", $subr_name, $msg);
2834 #------------------------------------------------------------------------------
2835 # Get the size of the hash that contains the archived files.
2836 #------------------------------------------------------------------------------
2837 ## $NO_OF_FILES_IN_ARCHIVE = scalar (keys %ARCHIVES_FILES);
2839 $no_of_files_in_selected_archive =
2840 $g_exp_dir_meta_data{$selected_archive}{"no_of_files_in_archive"};
2842 $msg = "number of files in archive $selected_archive is";
2843 $msg .= " " . $no_of_files_in_selected_archive;
2844 gp_message
("debug", $subr_name, $msg);
2846 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2848 my $is_empty = $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"};
2849 $msg = "archive directory $exp_dir/archives is";
2850 $msg .= $is_empty ?
" empty" : " not empty";
2851 gp_message
("debug", $subr_name, $msg);
2853 for my $exp_dir (sort keys %g_exp_dir_meta_data)
2855 if (not $g_exp_dir_meta_data{$exp_dir}{"archive_is_empty"})
2857 for my $object (sort keys
2858 %{$g_exp_dir_meta_data{$exp_dir}{"archive_files"}})
2860 $msg = $exp_dir . " " . $object . " ";
2862 $g_exp_dir_meta_data{$exp_dir}{'archive_files'}{$object};
2863 gp_message
("debug", $subr_name, $msg);
2868 return ($archive_dir_not_empty, $selected_archive, \
%elf_rats);
2870 } #-- End of subroutine check_validity_exp_dirs
2872 #------------------------------------------------------------------------------
2873 # Color the string and optionally mark it boldface.
2875 # For supported colors, see:
2876 # https://www.w3schools.com/colors/colors_names.asp
2877 #------------------------------------------------------------------------------
2880 my $subr_name = get_my_name
();
2882 my ($input_string, $boldface, $color) = @_;
2886 $colored_string = "<font color='" . $color . "'>";
2890 $colored_string .= "<b>";
2893 $colored_string .= $input_string;
2897 $colored_string .= "</b>";
2899 $colored_string .= "</font>";
2901 return ($colored_string);
2903 } #-- End of subroutine color_string
2905 #------------------------------------------------------------------------------
2906 # Generate the array with the info on the experiment(s).
2907 #------------------------------------------------------------------------------
2910 my $subr_name = get_my_name
();
2912 my ($experiment_dir_list_ref, $experiment_data_ref) = @_;
2914 my @experiment_dir_list = @
{ $experiment_dir_list_ref };
2915 my @experiment_data = @
{ $experiment_data_ref };
2917 my @experiment_stats_html = ();
2918 my $experiment_stats_line;
2922 $plural = ($#experiment_dir_list > 0) ?
"s:" : ":";
2924 $experiment_stats_line = "<h3>\n";
2925 $experiment_stats_line .= "Full pathnames to the input experiment";
2926 $experiment_stats_line .= $plural . "\n";
2927 $experiment_stats_line .= "</h3>\n";
2928 $experiment_stats_line .= "<pre>\n";
2930 for my $i (0 .. $#experiment_dir_list)
2932 $experiment_stats_line .= $experiment_dir_list[$i] . " (" ;
2933 $experiment_stats_line .= $experiment_data[$i]{"start_date"} . ")\n";
2935 $experiment_stats_line .= "</pre>\n";
2937 push (@experiment_stats_html, $experiment_stats_line);
2939 $msg = "experiment_stats_line = " . $experiment_stats_line;
2940 gp_message
("debugXL", $subr_name, $msg);
2942 return (\
@experiment_stats_html);
2944 } #-- End of subroutine create_exp_info
2946 #------------------------------------------------------------------------------
2947 # Trivial function to generate a tag. This has been made a function to ensure
2948 # consistency creating tags and also make it easier to change them.
2949 #------------------------------------------------------------------------------
2950 sub create_function_tag
2952 my $subr_name = get_my_name
();
2956 my $function_tag = "function_tag_" . $tag_id;
2958 return ($function_tag);
2960 } #-- End of subroutine create_function_tag
2962 #------------------------------------------------------------------------------
2963 # Generate and return a string with the credits. Note that this also ends
2964 # the HTML formatting controls.
2965 #------------------------------------------------------------------------------
2966 sub create_html_credits
2968 my $subr_name = get_my_name
();
2973 my @months = qw
(January February March April May June July
2974 August September October November December
);
2976 my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
2981 $the_date = $months[$mon] . " " . $mday . ", " . $year;
2984 $msg .= "Output generated by the $driver_cmd command ";
2985 $msg .= "on $the_date ";
2986 $msg .= "(GNU binutils version " . $binutils_version . ")";
2990 gp_message
("debug", $subr_name, "the date = $the_date");
2994 } #-- End of subroutine create_html_credits
2996 #------------------------------------------------------------------------------
2997 # Generate a string that contains all the necessary HTML header information,
3000 # See also https://www.w3schools.com for the details on the features used.
3001 #------------------------------------------------------------------------------
3002 sub create_html_header
3004 my $subr_name = get_my_name
();
3006 my ($title_ref) = @_;
3008 my $title = ${ $title_ref };
3010 my $LANG = $g_locale_settings{"LANG"};
3011 my $background_color = $g_html_color_scheme{"background_color_page"};
3015 $html_header = "<!DOCTYPE html public \"-//w3c//dtd html 3.2//en\">\n";
3016 $html_header .= "<html lang=\"$LANG\">\n";
3017 $html_header .= "<head>\n";
3018 $html_header .= "<meta http-equiv=\"content-type\"";
3019 $html_header .= " content=\"text/html; charset=iso-8859-1\">\n";
3020 $html_header .= "<title>" . $title . "</title>\n";
3021 $html_header .= "</head>\n";
3022 $html_header .= "<body lang=\"$LANG\" bgcolor=". $background_color . ">\n";
3023 $html_header .= "<style>\n";
3024 $html_header .= "div.left {\n";
3025 $html_header .= "text-align: left;\n";
3026 $html_header .= "}\n";
3027 $html_header .= "div.right {\n";
3028 $html_header .= "text-align: right;\n";
3029 $html_header .= "}\n";
3030 $html_header .= "div.center {\n";
3031 $html_header .= "text-align: center;\n";
3032 $html_header .= "}\n";
3033 $html_header .= "div.justify {\n";
3034 $html_header .= "text-align: justify;\n";
3035 $html_header .= "}\n";
3036 $html_header .= "</style>";
3038 return (\
$html_header);
3040 } #-- End of subroutine create_html_header
3042 #------------------------------------------------------------------------------
3043 # Create a complete table.
3044 #------------------------------------------------------------------------------
3047 my $subr_name = get_my_name
();
3049 my ($experiment_data_ref, $table_definition_ref) = @_;
3051 my @experiment_data = @
{ $experiment_data_ref };
3052 my @table_definition = @
{ $table_definition_ref };
3054 my @html_exp_table_data = ();
3055 my $html_header_line;
3056 my $html_table_line;
3059 $html_header_line = ${ create_table_header_exp
(\
@experiment_data) };
3061 push (@html_exp_table_data, $html_header_line);
3063 for my $i (sort keys @table_definition)
3065 $html_table_line = ${
3066 create_table_entry_exp
(\
$table_definition[$i]{"name"},
3067 \
$table_definition[$i]{"key"},
3068 \
@experiment_data) };
3069 push (@html_exp_table_data, $html_table_line);
3071 my $msg = "i = $i html_table_line = $html_table_line";
3072 gp_message
("debugXL", $subr_name, $msg);
3075 $html_end_table = "</table>\n";
3076 push (@html_exp_table_data, $html_end_table);
3078 return (\
@html_exp_table_data);
3080 } #-- End of subroutine create_table
3082 #------------------------------------------------------------------------------
3083 # Create one row for the table with experiment info.
3084 #------------------------------------------------------------------------------
3085 sub create_table_entry_exp
3087 my $subr_name = get_my_name
();
3089 my ($entry_name_ref, $key_ref, $experiment_data_ref) = @_;
3091 my $entry_name = ${ $entry_name_ref };
3092 my $key = ${ $key_ref };
3093 my @experiment_data = @
{ $experiment_data_ref };
3098 $msg = "entry_name = $entry_name key = $key";
3099 gp_message
("debugXL", $subr_name, $msg);
3101 ## $html_line = "<tr><div class=\"left\"><td><b> ";
3102 $html_line = "<tr><div class=\"right\"><td><b> ";
3103 $html_line .= $entry_name;
3104 $html_line .= " </b></td>";
3105 for my $i (sort keys @experiment_data)
3107 if (exists ($experiment_data[$i]{$key}))
3109 $html_line .= "<td> " . $experiment_data[$i]{$key};
3110 $html_line .= " </td>";
3114 $msg = "experiment_data[$i]{$key} does not exist";
3115 ## gp_message ("assertion", $subr_name, $msg);
3116 # TBD: warning or error?
3117 gp_message
("warning", $subr_name, $msg);
3120 $html_line .= "</div></tr>\n";
3122 gp_message
("debugXL", $subr_name, "return html_line = $html_line");
3124 return (\
$html_line);
3126 } #-- End of subroutine create_table_entry_exp
3128 #------------------------------------------------------------------------------
3129 # Create the table header for the experiment info.
3130 #------------------------------------------------------------------------------
3131 sub create_table_header_exp
3133 my $subr_name = get_my_name
();
3135 my ($experiment_data_ref) = @_;
3137 my @experiment_data = @
{ $experiment_data_ref };
3138 my $html_header_line;
3141 $html_header_line = "<style>\n";
3142 $html_header_line .= "table, th, td {\n";
3143 $html_header_line .= "border: 1px solid black;\n";
3144 $html_header_line .= "border-collapse: collapse;\n";
3145 $html_header_line .= "}\n";
3146 $html_header_line .= "</style>\n";
3147 $html_header_line .= "</pre>\n";
3148 $html_header_line .= "<table>\n";
3149 $html_header_line .= "<tr><div class=\"center\"><th></th>";
3151 for my $i (sort keys @experiment_data)
3153 $html_header_line .= "<th> Experiment ID ";
3154 $html_header_line .= $experiment_data[$i]{"exp_id"} . " </th>";
3156 $html_header_line .= "</div></tr>\n";
3158 $msg = "html_header_line = " . $html_header_line;
3159 gp_message
("debugXL", $subr_name, $msg);
3161 return (\
$html_header_line);
3163 } #-- End of subroutine create_table_header_exp
3165 #------------------------------------------------------------------------------
3166 # Handle where the output should go. If needed, a directory is created where
3167 # the results will go.
3168 #------------------------------------------------------------------------------
3169 sub define_the_output_directory
3171 my $subr_name = get_my_name
();
3173 my ($define_new_output_dir, $overwrite_output_dir) = @_;
3178 #------------------------------------------------------------------------------
3179 # If neither -o or -O are set, find the next number to be used in the name for
3180 # the default output directory.
3181 #------------------------------------------------------------------------------
3182 if ((not $define_new_output_dir) and (not $overwrite_output_dir))
3185 while (-d
"er.".$dir_id.".html")
3187 $outputdir = "er.".$dir_id.".html";
3192 #------------------------------------------------------------------------------
3193 # The -o option is used, but the directory already exists.
3194 #------------------------------------------------------------------------------
3195 if ($define_new_output_dir)
3197 $msg = "directory $outputdir already exists";
3198 gp_message
("error", $subr_name, $msg);
3199 $g_total_error_count++;
3201 $msg = "use the -O/--overwrite option to overwrite an existing";
3202 $msg .= " directory";
3203 gp_message
("abort", $subr_name, $msg);
3205 #------------------------------------------------------------------------------
3206 # This is a bit risky, so we proceed with caution. The output directory exists,
3207 # but it is okay to overwrite it. It is removed here and created again below.
3208 #------------------------------------------------------------------------------
3209 elsif ($overwrite_output_dir)
3211 my $target_cmd = $g_mapped_cmds{"rm"};
3212 my $rm_output = qx ($target_cmd -rf
$outputdir);
3213 my $error_code = ${^CHILD_ERROR_NATIVE
};
3214 if ($error_code != 0)
3216 gp_message
("error", $subr_name, $rm_output);
3217 $msg = "fatal error when trying to remove " . $outputdir;
3218 gp_message
("abort", $subr_name, $msg);
3222 $msg = "directory $outputdir has been removed";
3223 gp_message
("debug", $subr_name, $msg);
3227 #------------------------------------------------------------------------------
3228 # When we get here, the fatal scenarios have been cleared and the name for
3229 # $outputdir is known. Time to create it.
3230 #------------------------------------------------------------------------------
3231 if (mkdir ($outputdir, 0777))
3233 $msg = "created output directory " . $outputdir;
3234 gp_message
("debug", $subr_name, $msg);
3238 $msg = "a fatal problem occurred when creating directory " . $outputdir;
3239 gp_message
("abort", $subr_name, $msg);
3242 return ($outputdir);
3244 } #-- End of subroutine define_the_output_directory
3246 #------------------------------------------------------------------------------
3247 # Return the virtual address for the load object.
3249 # Note that at this point, $elf_arch is known to be supported.
3251 # TBD: Duplications?
3252 #------------------------------------------------------------------------------
3253 sub determine_base_va_address
3255 my $subr_name = get_my_name
();
3257 my ($executable_name, $base_va_executable, $loadobj, $routine) = @_;
3260 my $name_loadobject;
3261 my $base_va_address;
3263 $msg = "base_va_executable = " . $base_va_executable;
3264 gp_message
("debugXL", $subr_name, $msg);
3265 $msg = "loadobj = " . $loadobj;
3266 gp_message
("debugXL", $subr_name, $msg);
3267 $msg = "routine = " . $routine;
3268 gp_message
("debugXL", $subr_name, $msg);
3270 #------------------------------------------------------------------------------
3271 # Strip the pathname from the load object name.
3272 #------------------------------------------------------------------------------
3273 $name_loadobject = get_basename
($loadobj);
3275 #------------------------------------------------------------------------------
3276 # If the load object is the executable, return the base address determined
3277 # earlier. Otherwise return 0x0. Note that I am not sure if this is always
3278 # the right thing to do, but for .so files it seems to work out fine.
3279 #------------------------------------------------------------------------------
3280 if ($name_loadobject eq $executable_name)
3282 $base_va_address = $base_va_executable;
3286 $base_va_address = "0x0";
3289 my $decimal_address = bigint
::hex ($base_va_address);
3291 $msg = "return base_va_address = $base_va_address";
3292 $msg .= " (decimal: $decimal_address)";
3293 gp_message
("debugXL", $subr_name, $msg);
3295 return ($base_va_address);
3297 } #-- End of subroutine determine_base_va_address
3299 #------------------------------------------------------------------------------
3300 # Now that we know the map.xml file(s) are present, we can scan these and get
3301 # the required information.
3302 #------------------------------------------------------------------------------
3303 sub determine_base_virtual_address
3305 my $subr_name = get_my_name
();
3307 my ($exp_dir_list_ref) = @_;
3309 my @exp_dir_list = @
{ $exp_dir_list_ref };
3311 my $executable_name;
3314 my $path_to_map_file;
3315 my $va_executable_in_hex;
3317 for my $exp_dir (keys %g_exp_dir_meta_data)
3319 $path_to_map_file = $g_exp_dir_meta_data{$exp_dir}{"directory_path"};
3320 $path_to_map_file .= $exp_dir;
3321 $path_to_map_file .= "/map.xml";
3323 ($full_path_exec, $executable_name, $va_executable_in_hex) =
3324 extract_info_from_map_xml
($path_to_map_file);
3326 $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"} = $full_path_exec;
3327 $g_exp_dir_meta_data{$exp_dir}{"exec_name"} = $executable_name;
3328 $g_exp_dir_meta_data{$exp_dir}{"va_base_in_hex"} = $va_executable_in_hex;
3330 $msg = "exp_dir = " . $exp_dir;
3331 gp_message
("debug", $subr_name, $msg);
3332 $msg = "full_path_exece = " . $full_path_exec;
3333 gp_message
("debug", $subr_name, $msg);
3334 $msg = "executable_name = " . $executable_name;
3335 gp_message
("debug", $subr_name, $msg);
3336 $msg = "va_executable_in_hex = " . $va_executable_in_hex;
3337 gp_message
("debug", $subr_name, $msg);
3342 } #-- End of subroutine determine_base_virtual_address
3344 #------------------------------------------------------------------------------
3345 # Determine whether the decimal separator is a point or a comma.
3346 #------------------------------------------------------------------------------
3347 sub determine_decimal_separator
3349 my $subr_name = get_my_name
();
3353 my $decimal_separator;
3357 my @locale_info = ();
3362 my $default_decimal_separator = "\\.";
3364 $target_cmd = $g_mapped_cmds{locale
} . " -k LC_NUMERIC";
3365 ($error_code, $cmd_output) = execute_system_cmd
($target_cmd);
3367 if ($error_code != 0)
3368 #------------------------------------------------------------------------------
3369 # This is unlikely to happen, but you never know. To reduce the nesting level,
3370 # return right here in case of an error.
3371 #------------------------------------------------------------------------------
3373 $msg = "failure to execute the command " . $target_cmd;
3374 gp_message
("error", $subr_name, $msg);
3376 $g_total_error_count++;
3378 $convert_to_dot = $TRUE;
3380 return ($error_code, $default_decimal_separator, $convert_to_dot);
3383 #------------------------------------------------------------------------------
3384 #------------------------------------------------------------------------------
3385 # Scan the locale info and search for the target line of the form
3386 # decimal_point="<target>" where <target> is either a dot, or a comma.
3387 #------------------------------------------------------------------------------
3388 #------------------------------------------------------------------------------
3390 #------------------------------------------------------------------------------
3391 # Split the output into the different lines and scan for the line we need.
3392 #------------------------------------------------------------------------------
3393 @locale_info = split ("\n", $cmd_output);
3394 $target_found = $FALSE;
3395 for my $line (@locale_info)
3398 $msg = "line from locale_info = " . $line;
3399 gp_message
("debug", $subr_name, $msg);
3401 if ($line =~ /decimal_point=/)
3404 #------------------------------------------------------------------------------
3405 # Found the target line. Split this line to get the value field.
3406 #------------------------------------------------------------------------------
3407 my @split_line = split ("=", $line);
3409 #------------------------------------------------------------------------------
3410 # There should be 2 fields. If not, something went wrong.
3411 #------------------------------------------------------------------------------
3412 if (scalar @split_line != 2)
3414 # if (scalar @split_line == 2) {
3415 # $target_found = $FALSE;
3416 #------------------------------------------------------------------------------
3417 # Remove the newline before printing the variables.
3418 #------------------------------------------------------------------------------
3419 $ignore_count = chomp ($line);
3420 $ignore_count = chomp (@split_line);
3422 $msg = "line $line matches the search, but the decimal";
3423 $msg .= " separator has the wrong format";
3424 gp_message
("warning", $subr_name, $msg);
3425 $msg = "the splitted line is [@split_line] and does not";
3426 $msg .= " contain 2 fields";
3427 gp_message
("warning", $subr_name, $msg);
3428 $msg = "the default decimal separator will be used";
3429 gp_message
("warning", $subr_name, $msg);
3431 $g_total_warning_count++;
3435 #------------------------------------------------------------------------------
3436 # We know there are 2 fields and the second one has the decimal point.
3437 #------------------------------------------------------------------------------
3438 $msg = "split_line[1] = " . $split_line[1];
3439 gp_message
("debug", $subr_name, $msg);
3441 chomp ($split_line[1]);
3442 $field = $split_line[1];
3444 if (length ($field) != 3)
3445 #------------------------------------------------------------------------------
3446 # The field still includes the quotes. Check if the string has length 3, which
3447 # should be the case, but if not, we flag an error. The error code is set such
3448 # that the callee will know a problem has occurred.
3449 #------------------------------------------------------------------------------
3451 $msg = "unexpected output from the $target_cmd command:";
3452 $msg .= " " . $field;
3453 gp_message
("error", $subr_name, $msg);
3455 $g_total_error_count++;
3461 $msg = "field = ->$field<-";
3462 gp_message
("debug", $subr_name, $msg);
3464 if (($field eq "\".\"") or ($field eq "\",\""))
3465 #------------------------------------------------------------------------------
3466 # Found the separator. Capture the character between the quotes.
3467 #------------------------------------------------------------------------------
3469 $target_found = $TRUE;
3470 $decimal_separator = substr ($field,1,1);
3471 $msg = "decimal_separator = $decimal_separator--end";
3472 $msg .= " skip remainder of loop";
3473 gp_message
("debug", $subr_name, $msg);
3479 if (not $target_found)
3481 $decimal_separator = $default_decimal_separator;
3482 $msg = "cannot determine the decimal separator";
3483 $msg .= " - use the default " . $decimal_separator;
3484 gp_message
("warning", $subr_name, $msg);
3486 $g_total_warning_count++;
3489 if ($decimal_separator ne ".")
3491 $convert_to_dot = $TRUE;
3495 $convert_to_dot = $FALSE;
3498 $decimal_separator = "\\".$decimal_separator;
3499 $g_locale_settings{"decimal_separator"} = $decimal_separator;
3500 $g_locale_settings{"convert_to_dot"} = $convert_to_dot;
3502 return ($error_code, $decimal_separator, $convert_to_dot);
3504 } #-- End of subroutine determine_decimal_separator
3506 #------------------------------------------------------------------------------
3508 #------------------------------------------------------------------------------
3509 sub dump_function_info
3511 my $subr_name = get_my_name
();
3513 my ($function_info_ref, $name) = @_;
3515 my %function_info = %{$function_info_ref};
3519 $msg = "function_info for " . $name;
3520 gp_message
("debug", $subr_name, $msg);
3523 for my $farray ($function_info{$name})
3525 for my $elm (@
{$farray})
3527 $msg = $kip . ": routine = " . ${$elm}{"routine"};
3528 gp_message
("debug", $subr_name, $msg);
3529 for my $key (sort keys %{$elm})
3531 if ($key eq "routine")
3535 $msg = $kip . ": $key = " . ${$elm}{$key};
3536 gp_message
("debug", $subr_name, $msg);
3544 } #-- End of subroutine dump_function_info
3546 #------------------------------------------------------------------------------
3548 #------------------------------------------------------------------------------
3551 my $subr_name = get_my_name
();
3553 my ($elf_loadobjects_found, $elf_arch, $loadobj, $routine,
3554 $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_;
3556 my %elf_rats = %{$elf_rats_ref};
3561 #------------------------------------------------------------------------------
3562 # TBD. Quick check. Can be moved up the call tree.
3563 #------------------------------------------------------------------------------
3564 if ( $elf_arch ne "Linux" )
3566 $msg = $elf_arch . " is not a supported OS";
3567 gp_message
("error", $subr_name, $msg);
3568 $g_total_error_count++;
3569 gp_message
("abort", $subr_name, $g_abort_msg);
3572 #------------------------------------------------------------------------------
3573 # TBD: This should not be in a loop over $loadobj and only use the executable.
3574 #------------------------------------------------------------------------------
3576 #------------------------------------------------------------------------------
3577 # TBD: $routine is not really used in these subroutines. Is this a bug?
3578 #------------------------------------------------------------------------------
3579 if ($elf_loadobjects_found)
3581 gp_message
("debugXL", $subr_name, "calling elf_phdr_usual");
3582 $return_value = elf_phdr_usual
($elf_arch,
3589 gp_message
("debugXL", $subr_name, "calling elf_phdr_sometimes");
3590 $return_value = elf_phdr_sometimes
($elf_arch,
3594 $ARCHIVES_MAP_VADDR);
3597 gp_message
("debug", $subr_name, "the return value = $return_value");
3599 if (not $return_value)
3601 $msg = "need to handle a return value of FALSE";
3602 gp_message
("error", $subr_name, $msg);
3603 $g_total_error_count++;
3604 gp_message
("abort", $subr_name, $g_abort_msg);
3607 return ($return_value);
3609 } #-- End of subroutine elf_phdr
3611 #------------------------------------------------------------------------------
3612 # Return the virtual address for the load object.
3613 #------------------------------------------------------------------------------
3614 sub elf_phdr_sometimes
3616 my $subr_name = get_my_name
();
3618 my ($elf_arch, $loadobj, $routine, $ARCHIVES_MAP_NAME,
3619 $ARCHIVES_MAP_VADDR) = @_;
3621 my $arch_uname_s = $local_system_config{"kernel_name"};
3622 my $arch_uname = $local_system_config{"processor"};
3623 my $arch = $g_arch_specific_settings{"arch"};
3625 gp_message
("debug", $subr_name, "arch_uname_s = $arch_uname_s");
3626 gp_message
("debug", $subr_name, "arch_uname = $arch_uname");
3627 gp_message
("debug", $subr_name, "arch = $arch");
3655 if ($ARCHIVES_MAP_NAME eq $blo)
3657 return ($ARCHIVES_MAP_VADDR);
3664 if ($arch_uname_s ne $elf_arch)
3666 #------------------------------------------------------------------------------
3667 # We are masquerading between systems, must leave
3668 #------------------------------------------------------------------------------
3669 $msg = "masquerading arch_uname_s->$arch_uname_s elf_arch->$elf_arch";
3670 gp_message
("debug", $subr_name, $msg);
3674 if ($loadobj eq "DYNAMIC_FUNCTIONS")
3675 #------------------------------------------------------------------------------
3676 # Linux vDSO, leave for now
3677 #------------------------------------------------------------------------------
3682 # TBD: STILL NEEDED??!!
3684 $loadobj_SAVE = $loadobj;
3686 $blo = get_basename
($loadobj);
3687 gp_message
("debug", $subr_name, "loadobj = $loadobj");
3688 gp_message
("debug", $subr_name, "blo = $blo");
3689 gp_message
("debug", $subr_name, "ARCHIVES_MAP_NAME = $ARCHIVES_MAP_NAME");
3690 gp_message
("debug", $subr_name, "ARCHIVES_MAP_VADDR = $ARCHIVES_MAP_VADDR");
3691 if ($ARCHIVES_MAP_NAME eq $blo)
3693 return ($ARCHIVES_MAP_VADDR);
3700 } #-- End of subroutine elf_phdr_sometimes
3702 #------------------------------------------------------------------------------
3703 # Return the virtual address for the load object.
3705 # Note that at this point, $elf_arch is known to be supported.
3706 #------------------------------------------------------------------------------
3709 my $subr_name = get_my_name
();
3711 my ($elf_arch, $loadobj, $routine, $elf_rats_ref) = @_;
3713 my %elf_rats = %{$elf_rats_ref};
3715 my $load_long_regex;
3716 $load_long_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)';
3717 $load_long_regex .= '\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$';
3718 my $load_short_regex = '^\s+LOAD\s+(\S+)\s+(\S+)\s+(\S+)$';
3719 my $re_regex = '^\s+(\S+)\s+(\S+)\s+(R\sE)\s+(\S+)$';
3730 my ($elf_offset, $loadobjARC);
3731 my ($i, @foo, $foo, $foo1, $p_vaddr, $rc);
3732 my ($Offset, $VirtAddr, $PhysAddr, $FileSiz, $MemSiz, $Flg, $Align);
3734 my $arch_uname_s = $local_system_config{"kernel_name"};
3736 $msg = "elf_arch = $elf_arch loadobj = $loadobj routine = $routine";
3737 gp_message
("debug", $subr_name, $msg);
3739 my ($base, $ignore_value, $ignore_too) = fileparse
($loadobj);
3741 $msg = "base = $base " . basename
($loadobj);
3742 gp_message
("debug", $subr_name, $msg);
3744 if ($elf_arch eq "Linux")
3746 if ($arch_uname_s ne $elf_arch)
3748 #------------------------------------------------------------------------------
3749 # We are masquerading between systems, must leave.
3750 # Maybe we could use ELF_RATS
3751 #------------------------------------------------------------------------------
3752 $msg = "masquerading arch_uname_s->" . $arch_uname_s;
3753 $msg .= " elf_arch->" . $elf_arch;
3754 gp_message
("debug", $subr_name, $msg);
3758 if ($loadobj eq "DYNAMIC_FUNCTIONS")
3760 #------------------------------------------------------------------------------
3761 # Linux vDSO, leave for now
3762 #------------------------------------------------------------------------------
3763 gp_message
("debug", $subr_name, "early return: loadobj = $loadobj");
3767 $target_cmd = $g_mapped_cmds{"readelf"};
3768 $command_string = $target_cmd . " -l " . $loadobj . " 2>/dev/null";
3770 ($error_code1, $cmd_output) = execute_system_cmd
($command_string);
3772 $msg = "executed command_string = " . $command_string;
3773 gp_message
("debug", $subr_name, $msg);
3774 $msg = "cmd_output = " . $cmd_output;
3775 gp_message
("debug", $subr_name, $msg);
3777 if ($error_code1 != 0)
3779 gp_message
("debug", $subr_name, "call failure for $command_string");
3780 #------------------------------------------------------------------------------
3781 # e.g. $loadobj->/usr/lib64/libc-2.17.so
3782 #------------------------------------------------------------------------------
3783 $loadobjARC = get_basename
($loadobj);
3784 gp_message
("debug", $subr_name, "seek elf_rats for $loadobjARC");
3786 if (exists ($elf_rats{$loadobjARC}))
3789 $elfoid = $elf_rats{$loadobjARC}[1] . "/archives/";
3790 $elfoid .= $elf_rats{$loadobjARC}[0];
3791 $target_cmd = $g_mapped_cmds{"readelf"};
3792 $command_string = $target_cmd . "-l " . $elfoid . " 2>/dev/null";
3793 ($error_code2, $cmd_output) =
3794 execute_system_cmd
($command_string);
3796 if ($error_code2 != 0)
3798 $msg = "call failure for " . $command_string;
3799 gp_message
("error", $subr_name, $msg);
3800 $g_total_error_count++;
3801 gp_message
("abort", $subr_name, $g_abort_msg);
3805 $msg = "executed command_string = " . $command_string;
3806 gp_message
("debug", $subr_name, $msg);
3807 $msg = "cmd_output = " . $cmd_output;
3808 gp_message
("debug", $subr_name, $msg);
3813 $msg = "elf_rats{$loadobjARC} does not exist";
3814 gp_message
("assertion", $subr_name, $msg);
3817 #------------------------------------------------------------------------------
3818 # Example output of "readelf -l" on Linux:
3820 # Elf file type is EXEC (Executable file)
3821 # Entry point 0x4023a0
3822 # There are 11 program headers, starting at offset 64
3825 # Type Offset VirtAddr PhysAddr
3826 # FileSiz MemSiz Flags Align
3827 # PHDR 0x0000000000000040 0x0000000000400040 0x0000000000400040
3828 # 0x0000000000000268 0x0000000000000268 R 8
3829 # INTERP 0x00000000000002a8 0x00000000004002a8 0x00000000004002a8
3830 # 0x000000000000001c 0x000000000000001c R 1
3831 # [Requesting program interpreter: /lib64/ld-linux-x86-64.so.2]
3832 # LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000
3833 # 0x0000000000001310 0x0000000000001310 R 1000
3834 # LOAD 0x0000000000002000 0x0000000000402000 0x0000000000402000
3835 # 0x0000000000006515 0x0000000000006515 R E 1000
3836 # LOAD 0x0000000000009000 0x0000000000409000 0x0000000000409000
3837 # 0x000000000006f5a8 0x000000000006f5a8 R 1000
3838 # LOAD 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8
3839 # 0x000000000000047c 0x0000000000000f80 RW 1000
3840 # DYNAMIC 0x0000000000078dd8 0x0000000000479dd8 0x0000000000479dd8
3841 # 0x0000000000000220 0x0000000000000220 RW 8
3842 # NOTE 0x00000000000002c4 0x00000000004002c4 0x00000000004002c4
3843 # 0x0000000000000044 0x0000000000000044 R 4
3844 # GNU_EH_FRAME 0x00000000000777f4 0x00000000004777f4 0x00000000004777f4
3845 # 0x000000000000020c 0x000000000000020c R 4
3846 # GNU_STACK 0x0000000000000000 0x0000000000000000 0x0000000000000000
3847 # 0x0000000000000000 0x0000000000000000 RW 10
3848 # GNU_RELRO 0x0000000000078dc8 0x0000000000479dc8 0x0000000000479dc8
3849 # 0x0000000000000238 0x0000000000000238 R 1
3851 # Section to Segment mapping:
3852 # Segment Sections...
3855 # 02 .interp .note.gnu.build-id .note.ABI-tag .gnu.hash .dynsym
3856 # .dynstr .gnu.version .gnu.version_r .rela.dyn .rela.plt
3857 # 03 .init .plt .text .fini
3858 # 04 .rodata .eh_frame_hdr .eh_frame
3859 # 05 .init_array .fini_array .dynamic .got .got.plt .data .bss
3861 # 07 .note.gnu.build-id .note.ABI-tag
3864 # 10 .init_array .fini_array .dynamic .got
3865 #------------------------------------------------------------------------------
3867 #------------------------------------------------------------------------------
3868 # Analyze the ELF information and try to find the virtual address.
3870 # Note that the information printed as part of LOAD needs to have "R E" in it.
3871 # In the example output above, the return value would be "0x0000000000402000".
3873 # We also need to distinguish two cases. It could be that the output is on
3874 # a single line, or spread over two lines:
3876 # Offset VirtAddr PhysAddr FileSiz MemSiz Flg Align
3877 # LOAD 0x000000 0x08048000 0x08048000 0x61b4ae 0x61b4ae R E 0x1000
3879 # LOAD 0x0000000000000000 0x0000000000400000 0x0000000000400000
3880 # 0x0000000000001010 0x0000000000001010 R E 200000
3881 #------------------------------------------------------------------------------
3882 @foo = split ("\n",$cmd_output);
3887 if ($foo =~ /$load_long_regex/)
3897 $elf_offset = $VirtAddr;
3898 $msg = "single line version elf_offset = " . $elf_offset;
3899 gp_message
("debug", $subr_name, $msg);
3900 return ($elf_offset);
3902 elsif ($foo =~ /$load_short_regex/)
3904 #------------------------------------------------------------------------------
3905 # is it a two line version?
3906 #------------------------------------------------------------------------------
3908 $VirtAddr = $2; # maybe
3912 $foo1 = $foo[$i + 1];
3914 if ($foo1 =~ /$re_regex/)
3920 $elf_offset = $VirtAddr;
3921 $msg = "two line version elf_offset = " . $elf_offset;
3922 gp_message
("debug", $subr_name, $msg);
3923 return ($elf_offset);
3930 } #-- End of subroutine elf_phdr_usual
3932 #------------------------------------------------------------------------------
3933 # Execute a system command. In case of an error, a non-zero error code is
3934 # returned. It is upon the caller to decide what to do next.
3935 #------------------------------------------------------------------------------
3936 sub execute_system_cmd
3938 my $subr_name = get_my_name
();
3940 my ($target_cmd) = @_;
3946 chomp ($target_cmd);
3948 $cmd_output = qx ($target_cmd);
3949 $error_code = ${^CHILD_ERROR_NATIVE
};
3951 if ($error_code != 0)
3953 chomp ($cmd_output);
3954 $msg = "failure executing command " . $target_cmd;
3955 gp_message
("error", $subr_name, $msg);
3956 $msg = "error code = " . $error_code;
3957 gp_message
("error", $subr_name, $msg);
3958 $msg = "cmd_output = " . $cmd_output;
3960 gp_message
("error", $subr_name, $msg);
3961 $g_total_error_count++;
3965 $msg = "executed command " . $target_cmd;
3966 gp_message
("debugXL", $subr_name, $msg);
3969 return ($error_code, $cmd_output);
3971 } #-- End of subroutine execute_system_cmd
3973 #------------------------------------------------------------------------------
3974 # Scan the input file, which should be a gprofng generated map.xml file, and
3975 # extract the relevant information.
3976 #------------------------------------------------------------------------------
3977 sub extract_info_from_map_xml
3979 my $subr_name = get_my_name
();
3981 my ($input_map_xml_file) = @_;
3984 $map_xml_regex = '<event kind="map"\s.*';
3985 $map_xml_regex .= 'vaddr="0x([0-9a-fA-F]+)"\s+.*';
3986 $map_xml_regex .= 'foffset="\+*0x([0-9a-fA-F]+)"\s.*';
3987 $map_xml_regex .= 'modes="0x([0-9]+)"\s.*';
3988 $map_xml_regex .= 'name="(.*)".*>$';
3990 my $extracted_information;
4000 my $executable_name;
4002 my $va_executable_in_hex;
4004 $msg = "- unable to open file $input_map_xml_file for reading:";
4005 open (MAP_XML
, "<", $input_map_xml_file)
4006 or die ($subr_name . $msg . " " . $!);
4008 $msg = "opened file $input_map_xml_file for reading";
4009 gp_message
("debug", $subr_name, $msg);
4011 #------------------------------------------------------------------------------
4012 # Scan the file. We need to find the name of the executable with the mode set
4013 # to 0x005. For this entry we have to capture the name, the mode, the virtual
4014 # address and the offset.
4015 #------------------------------------------------------------------------------
4016 $extracted_information = $FALSE;
4020 chomp ($input_line);
4022 $msg = "read input_line = $input_line";
4023 gp_message
("debug", $subr_name, $msg);
4025 if ($input_line =~ /^$map_xml_regex/)
4027 $msg = "target line = $input_line";
4028 gp_message
("debug", $subr_name, $msg);
4034 $name = get_basename
($name_path);
4036 $msg = "extracted vaddr = $vaddr foffset = $foffset";
4037 $msg .= " modes = $modes";
4038 gp_message
("debug", $subr_name, $msg);
4040 $msg = "extracted name_path = $name_path name = $name";
4041 gp_message
("debug", $subr_name, $msg);
4043 #------------------------------------------------------------------------------
4044 # The base virtual address is calculated as vaddr-foffset. Although Perl
4045 # handles arithmetic in hex, we take the safe way here. Maybe overkill, but
4046 # I prefer to be safe than sorry in cases like this.
4047 #------------------------------------------------------------------------------
4048 $full_path_exec = $name_path;
4049 $executable_name = $name;
4050 $result_VA = bigint
::hex ($vaddr) - bigint
::hex ($foffset);
4051 $va_executable_in_hex = sprintf ("0x%016x", $result_VA);
4053 ## $ARCHIVES_MAP_NAME = $name;
4054 ## $ARCHIVES_MAP_VADDR = $va_executable_in_hex;
4056 $msg = "result_VA = $result_VA";
4057 gp_message
("debug", $subr_name, $msg);
4059 $msg = "va_executable_in_hex = $va_executable_in_hex";
4060 gp_message
("debug", $subr_name, $msg);
4062 #------------------------------------------------------------------------------
4063 # Stop reading when we found the correct entry.
4064 #------------------------------------------------------------------------------
4065 if ($modes eq "005")
4067 $extracted_information = $TRUE;
4071 } #-- End of while-loop
4073 if (not $extracted_information)
4075 $msg = "cannot find the necessary information in file";
4076 $msg .= " " . $input_map_xml_file;
4077 gp_message
("assertion", $subr_name, $msg);
4080 $msg = "full_path_exec = $full_path_exec";
4081 gp_message
("debug", $subr_name, $msg);
4082 $msg = "executable_name = $executable_name";
4083 gp_message
("debug", $subr_name, $msg);
4084 $msg = "va_executable_in_hex = $va_executable_in_hex";
4085 gp_message
("debug", $subr_name, $msg);
4087 return ($full_path_exec, $executable_name, $va_executable_in_hex);
4089 } #-- End of subroutine extract_info_from_map_xml
4091 #------------------------------------------------------------------------------
4092 # This routine analyzes the metric line and extracts the metric specifics
4094 # Example input: Exclusive Total CPU Time: e.%totalcpu
4095 #------------------------------------------------------------------------------
4096 sub extract_metric_specifics
4098 my $subr_name = get_my_name
();
4100 my ($metric_line) = @_;
4102 my $metric_description;
4104 my $metric_visibility;
4108 # Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){
4109 if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/))
4111 gp_message
("debug", $subr_name, "line of interest: $metric_line");
4113 $metric_description = $1;
4114 $metric_flavor = $2;
4115 $metric_visibility = $3;
4118 #------------------------------------------------------------------------------
4119 # Although we have captured the metric visibility, the original code removes
4120 # this from the name. Since the structure is more complicated, the code is
4121 # more tedious as well. With our new approach we just leave the visibility
4123 #------------------------------------------------------------------------------
4124 # $metric_spec = $metric_flavor.$metric_visibility.$metric_name;
4126 $metric_spec = $metric_flavor . "." . $metric_name;
4128 #------------------------------------------------------------------------------
4129 # From the original code:
4131 # On x64 systems there are metrics which contain ~ (for example
4132 # DC_access~umask=0 . When er_print lists them, they come out
4133 # as DC_access%7e%umask=0 (see 6530691). Untill 6530691 is
4134 # fixed, we need this. Later we may need something else, or
4135 # things may just work.
4136 #------------------------------------------------------------------------------
4137 # $metric_spec=~s/\%7e\%/,/;
4139 # print "DB: before \$metric_spec = $metric_spec\n";
4141 #------------------------------------------------------------------------------
4142 # TBD: I don't know why the "%" symbol is removed.
4143 #------------------------------------------------------------------------------
4144 # $metric_spec =~ s/\%//;
4145 # print "DB: after \$metric_spec = $metric_spec\n";
4147 return ($metric_spec, $metric_flavor, $metric_visibility,
4148 $metric_name, $metric_description);
4152 return ("skipped", "void");
4155 } #-- End of subroutine extract_metric_specifics
4157 #------------------------------------------------------------------------------
4158 # Extract the option value(s) from the input array. In case the number of
4159 # values execeeds the specified limit, warning messages are printed.
4161 # In case the option value is valid, g_user_settings is updated with this
4162 # value and a value of TRUE is returned. Otherwise the return value is FALSE.
4164 # Note that not in all invocations of this subroutine, gp_message() is
4165 # operational. Only after the debug settings have been finalized, the
4166 # messages are printed.
4168 # This subroutine also generates warnings about multiple occurrences
4169 # and the validity of the values.
4170 #------------------------------------------------------------------------------
4171 sub extract_option_value
4173 my $subr_name = get_my_name
();
4175 my ($option_dir_ref, $max_occurrences_ref, $internal_option_name_ref,
4176 $option_name_ref) = @_;
4178 my @option_dir = @
{ $option_dir_ref };
4179 my $max_occurrences = ${ $max_occurrences_ref };
4180 my $internal_option_name = ${ $internal_option_name_ref };
4181 my $option_name = ${ $option_name_ref };
4183 my $deprecated_option_used;
4184 my $excess_occurrences;
4186 my $no_of_occurrences;
4187 my $no_of_warnings = 0;
4188 my $option_value = "not set yet";
4189 my $option_value_missing;
4190 my $option_value_missing_ref;
4191 my $reset_blank_value;
4192 my $special_treatment = $FALSE;
4198 $no_of_occurrences = scalar (@option_dir);
4200 $msg = "option_name = $option_name";
4201 gp_message
("debug", $subr_name, $msg);
4202 $msg = "internal_option_name = $internal_option_name";
4203 gp_message
("debug", $subr_name, $msg);
4204 $msg = "no_of_occurrences = $no_of_occurrences";
4205 gp_message
("debug", $subr_name, $msg);
4207 $excess_occurrences = ($no_of_occurrences > $max_occurrences) ?
4210 #------------------------------------------------------------------------------
4211 # This is not supposed to happen, but just to be sure, there is a check.
4212 #------------------------------------------------------------------------------
4213 if ($no_of_occurrences < 1)
4215 $msg = "the number of fields is $no_of_occurrences";
4216 $msg .= " - should at least be 1";
4217 gp_message
("assertion", $subr_name, $msg);
4220 #------------------------------------------------------------------------------
4221 # For backward compatibility, we support the legacy "on" and "off" values for
4224 # We also support the debug option without value. In case no value is given,
4225 # it is set to "on".
4227 # Note that regardless of the value(s) in ARGV, internally we use the on/off
4229 #------------------------------------------------------------------------------
4230 if (($g_user_settings{$internal_option_name}{"data_type"} eq "onoff") or
4231 ($internal_option_name eq "debug"))
4233 $msg = "enable special treatment of the option";
4234 gp_message
("debug", $subr_name, $msg);
4236 $special_treatment = $TRUE;
4239 #------------------------------------------------------------------------------
4240 # Issue a warning if the same option occcurs more often than what is supported.
4241 #------------------------------------------------------------------------------
4242 if ($excess_occurrences)
4244 $msg = "multiple occurrences of the " . $option_name .
4247 gp_message
("debugM", $subr_name, $msg);
4249 gp_message
("warning", $subr_name, $g_html_new_line . $msg);
4252 #------------------------------------------------------------------------------
4253 # Main loop over all the occurrences of the options. This is a rather simple
4254 # approach since only the last value seen will be accepted.
4256 # To assist the user with troubleshooting, the values that are ignored will be
4257 # checked for validity and a marker to this extent will be printed.
4260 # If an option may have multiple meaningful occurrences, this part needs to be
4262 #------------------------------------------------------------------------------
4263 $deprecated_option_used = $FALSE;
4264 for my $key (keys @option_dir)
4266 $option_value = $option_dir[$key];
4267 $reset_blank_value = $FALSE;
4269 #------------------------------------------------------------------------------
4270 # For the "onoff" options, convert a blank value to "on".
4271 #------------------------------------------------------------------------------
4272 if (($option_value eq "on") or ($option_value eq "off"))
4274 if (($option_name eq "--verbose") or ($option_name eq "--quiet"))
4276 $deprecated_option_used = $TRUE;
4280 #------------------------------------------------------------------------------
4281 # For the "onoff" options, convert a blank value to "on".
4282 #------------------------------------------------------------------------------
4283 if ($special_treatment and ($option_value eq ""))
4285 $option_value = "on";
4286 $reset_blank_value = $TRUE;
4288 $msg = "reset option value for $option_name from blank";
4289 $msg .= " to \"on\"";
4290 gp_message
("debug", $subr_name, $msg);
4293 #------------------------------------------------------------------------------
4294 # Check for the option value to be valid. It may also happen that an option
4295 # does not have a value, while it should have one.
4296 #------------------------------------------------------------------------------
4297 ($valid_ref, $option_value_missing_ref) = check_and_set_user_option
(
4298 $internal_option_name,
4301 $valid = ${ $valid_ref };
4302 $option_value_missing = ${ $option_value_missing_ref };
4304 $msg = "option_value = $option_value";
4305 gp_message
("debug", $subr_name, $msg);
4306 $msg = "after check_and_set_user_option: valid = $valid";
4307 $msg .= " option_value_missing = $option_value_missing";
4308 gp_message
("debug", $subr_name, $msg);
4310 #------------------------------------------------------------------------------
4311 # Generate warning messages, but if an option value is missing, it will also
4312 # be considered to be a fatal error.
4313 #------------------------------------------------------------------------------
4314 if ($excess_occurrences)
4316 if ($option_value_missing)
4318 $msg = "$option_name option - missing a value";
4322 #------------------------------------------------------------------------------
4323 # A little trick to avoid user confusion. Although we have set the internal
4324 # value to "on", the user did not set this and so we print "" instead.
4325 #------------------------------------------------------------------------------
4326 if ($reset_blank_value)
4328 $msg = "$option_name option - value = \"\"";
4332 $msg = "$option_name option - value = $option_value";
4334 $msg .= ($valid) ?
" (valid value)" : " (invalid value)";
4337 gp_message
("debug", $subr_name, $msg);
4338 gp_message
("warning", $subr_name, $msg);
4341 #------------------------------------------------------------------------------
4342 # Check for the last occurrence of the option to be valid. If it is not, it
4344 #------------------------------------------------------------------------------
4345 if ((not $valid) && ($key == $no_of_occurrences-1))
4347 if ($option_value_missing)
4349 $msg = "the $option_name option requires a value";
4353 $msg = "the value of $option_value for the $option_name";
4354 $msg .= " option is invalid";
4356 gp_message
("debug", $subr_name, $g_error_keyword . $msg);
4358 gp_message
("error", $subr_name, $msg);
4360 $g_total_error_count++;
4364 #------------------------------------------------------------------------------
4365 # Issue a warning if the same option occcurs more often than what is supported
4366 # and warn the user that all but the last value will be ignored.
4367 #------------------------------------------------------------------------------
4368 if ($excess_occurrences)
4370 $msg = "all values but the last one shown above are ignored";
4372 gp_message
("debugM", $subr_name, $msg);
4373 gp_message
("warning", $subr_name, $msg);
4375 $g_total_warning_count++;
4379 #------------------------------------------------------------------------------
4380 # Issue a warning if the old on/off syntax is used still.
4381 #------------------------------------------------------------------------------
4382 if ($deprecated_option_used)
4385 $msg .= "the on/off syntax for option $option_name has been";
4386 $msg .= " deprecated";
4387 gp_message
("warning", $subr_name, $msg);
4389 $msg = "this option acts like a switch now";
4390 gp_message
("warning", $subr_name, $msg);
4392 $msg = "support for the old syntax may be terminated";
4393 $msg .= " in a future update";
4394 gp_message
("warning", $subr_name, $msg);
4396 $msg = "please check the man page of gp-display-html";
4397 $msg .= " for more details";
4398 gp_message
("warning", $subr_name, $msg);
4399 $g_total_warning_count++;
4404 } #-- End of subroutine extract_option_value
4406 #------------------------------------------------------------------------------
4408 #------------------------------------------------------------------------------
4409 sub extract_source_line_number
4411 my $subr_name = get_my_name
();
4413 my ($src_times_regex, $function_regex, $number_of_metrics, $input_line) = @_;
4415 #------------------------------------------------------------------------------
4416 # The regex section.
4417 #------------------------------------------------------------------------------
4418 my $find_dot_regex = '\.';
4420 my @fields_in_line = ();
4424 #------------------------------------------------------------------------------
4425 # To extract the source line number, we need to distinguish whether this is
4426 # a line with, or without metrics.
4427 #------------------------------------------------------------------------------
4428 @fields_in_line = split (" ", $input_line);
4429 if ( $input_line =~ /$src_times_regex/ )
4432 if ($hot_line eq "##")
4433 #------------------------------------------------------------------------------
4434 # The line id comes after the "##" symbol and the metrics.
4435 #------------------------------------------------------------------------------
4437 $line_id = $fields_in_line[$number_of_metrics+1];
4440 #------------------------------------------------------------------------------
4441 # The line id comes after the metrics.
4442 #------------------------------------------------------------------------------
4444 $line_id = $fields_in_line[$number_of_metrics];
4447 elsif ($input_line =~ /$function_regex/)
4452 #------------------------------------------------------------------------------
4453 # The line id is the first non-blank element.
4454 #------------------------------------------------------------------------------
4456 $line_id = $fields_in_line[0];
4458 #------------------------------------------------------------------------------
4459 # Remove the trailing dot.
4460 #------------------------------------------------------------------------------
4461 $line_id =~ s/$find_dot_regex//;
4465 } #-- End of subroutine extract_source_line_number
4467 #------------------------------------------------------------------------------
4468 # Finalize the settings for the special options verbose, debug, warnings and
4470 #------------------------------------------------------------------------------
4471 sub finalize_special_options
4473 my $subr_name = get_my_name
();
4477 #------------------------------------------------------------------------------
4478 # If quiet mode has been enabled, disable verbose, warnings and debug.
4479 #------------------------------------------------------------------------------
4482 $g_user_settings{"verbose"}{"current_value"} = "off";
4483 $g_user_settings{"nowarnings"}{"current_value"} = "on";
4484 $g_user_settings{"warnings"}{"current_value"} = "off";
4485 $g_user_settings{"debug"}{"current_value"} = "off";
4487 $g_verbose = $FALSE;
4488 $g_warnings = $FALSE;
4489 my $debug_off = "off";
4490 my $ignore_value = set_debug_size
(\
$debug_off);
4494 #------------------------------------------------------------------------------
4495 # Disable output buffering if verbose, debug, and/or warnings are enabled.
4496 #------------------------------------------------------------------------------
4497 if ($g_verbose or $g_debug or $g_warnings)
4499 STDOUT
->autoflush (1);
4501 $msg = "enabled autoflush for STDOUT";
4502 gp_message
("debug", $subr_name, $msg);
4504 #------------------------------------------------------------------------------
4505 # If verbose and/or debug have been enabled, print a message.
4506 #------------------------------------------------------------------------------
4507 ## gp_message ("verbose", $subr_name, "verbose mode has been enabled");
4508 ## gp_message ("debug", $subr_name, "debug " . $g_debug_size_value . " mode has been enabled");
4513 } #-- End of subroutine finalize_special_options
4515 #------------------------------------------------------------------------------
4516 # For a give routine name and address, find the index into the
4517 # function_info array
4518 #------------------------------------------------------------------------------
4519 sub find_index_in_function_info
4521 my $subr_name = get_my_name
();
4523 my ($routine_ref, $current_address_ref, $function_info_ref) = @_;
4525 my $routine = ${ $routine_ref };
4526 my $current_address = ${ $current_address_ref };
4527 my @function_info = @
{ $function_info_ref };
4532 gp_message
("debugXL", $subr_name, "find index for routine = $routine and current_address = $current_address");
4533 if (exists ($g_multi_count_function{$routine}))
4536 # TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!!
4538 gp_message
("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
4539 for my $ref (keys @
{ $g_map_function_to_index{$routine} })
4541 $ref_index = $g_map_function_to_index{$routine}[$ref];
4543 gp_message
("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
4544 gp_message
("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
4546 $addr_offset = $function_info[$ref_index]{"addressobjtext"};
4547 gp_message
("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
4549 $addr_offset =~ s/^@\d+://;
4550 gp_message
("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
4551 if ($addr_offset eq $current_address)
4559 #------------------------------------------------------------------------------
4560 # There is only a single occurrence and it is straightforward to get the index.
4561 #------------------------------------------------------------------------------
4562 if (exists ($g_map_function_to_index{$routine}))
4564 $ref_index = $g_map_function_to_index{$routine}[0];
4568 my $msg = "index for $routine cannot be determined";
4569 gp_message
("assertion", $subr_name, $msg);
4573 gp_message
("debugXL", $subr_name, "routine = $routine current_address = $current_address ref_index = $ref_index");
4575 return (\
$ref_index);
4577 } #-- End of subroutine find_index_in_function_info
4579 #------------------------------------------------------------------------------
4581 #------------------------------------------------------------------------------
4582 sub find_keyword_in_string
4584 my $subr_name = get_my_name
();
4586 my ($target_string_ref, $target_keyword_ref) = @_;
4588 my $target_string = ${ $target_string_ref };
4589 my $target_keyword = ${ $target_keyword_ref };
4590 my $foundit = $FALSE;
4592 my @index_values = ();
4596 gp_message
("debugXL", $subr_name, "target_string = $target_string");
4597 $ret_val = index ($target_string, $target_keyword, $offset);
4598 gp_message
("debugXL", $subr_name, "ret_val = $ret_val");
4603 while ($ret_val != -1)
4605 push (@index_values, $ret_val);
4606 $offset = $ret_val + 1;
4607 gp_message
("debugXL", $subr_name, "ret_val = $ret_val offset = $offset");
4608 $ret_val = index ($target_string, $target_keyword, $offset);
4610 for my $i (keys @index_values)
4612 gp_message
("debugXL", $subr_name, "index_values[$i] = $index_values[$i]");
4617 gp_message
("debugXL", $subr_name, "target keyword $target_keyword not found");
4620 return (\
$foundit, \
@index_values);
4622 } #-- End of subroutine find_keyword_in_string
4624 #------------------------------------------------------------------------------
4625 # Retrieve the absolute path that was used to execute the command. This path
4626 # is used to execute gp-display-text later on.
4627 #------------------------------------------------------------------------------
4628 sub find_path_to_gp_display_text
4630 my $subr_name = get_my_name
();
4632 my ($full_command_ref) = @_;
4634 my $full_command = ${ $full_command_ref };
4636 my $error_occurred = $TRUE;
4639 #------------------------------------------------------------------------------
4640 # Get the path name.
4641 #------------------------------------------------------------------------------
4642 my ($gp_file_name, $gp_path, $suffix_not_used) = fileparse
($full_command);
4644 gp_message
("debug", $subr_name, "full_command = $full_command");
4645 gp_message
("debug", $subr_name, "gp_path = $gp_path");
4647 my $gp_display_text_instance = $gp_path . $GP_DISPLAY_TEXT;
4649 #------------------------------------------------------------------------------
4650 # Check if $GP_DISPLAY_TEXT exists, is not empty, and executable.
4651 #------------------------------------------------------------------------------
4652 if (not -e
$gp_display_text_instance)
4654 $return_value = "file not found";
4658 if (is_file_empty
($gp_display_text_instance))
4660 $return_value = "file is empty";
4664 #------------------------------------------------------------------------------
4665 # All is well. Capture the path.
4666 #------------------------------------------------------------------------------
4667 $error_occurred = $FALSE;
4668 $return_value = $gp_path;
4672 return (\
$error_occurred, \
$gp_path, \
$return_value);
4674 } #-- End of subroutine find_path_to_gp_display_text
4676 #------------------------------------------------------------------------------
4677 # Scan the command line to see if the specified option is present.
4679 # Two types of options are supported: options without a value (e.g. --help) or
4680 # those that are set to "on" or "off".
4682 # In this phase, we only need to check if a value is valid. If it is, we have
4683 # to enable the corresponding global setting. If the value is not valid, we
4684 # ignore it, since it will be caught later and a warning message is issued.
4685 #------------------------------------------------------------------------------
4686 sub find_target_option
4688 my $subr_name = get_my_name
();
4690 my ($command_line_ref, $option_requires_value, $target_option) = @_;
4692 my @command_line = @
{ $command_line_ref };
4693 my $option_value = undef;
4694 my $found_option = $FALSE;
4696 my ($command_line_string) = join (" ", @command_line);
4698 ## if ($command_line_string =~ /\s*($target_option)\s*(on|off)*\s*/)
4699 #------------------------------------------------------------------------------
4700 # This does not make any assumptions on the values we are looking for.
4701 #------------------------------------------------------------------------------
4702 if ($command_line_string =~ /\s*\-\-($target_option)\s*(\w*)\s*/)
4705 #------------------------------------------------------------------------------
4706 # We have found the option we are looking for.
4707 #------------------------------------------------------------------------------
4709 $found_option = $TRUE;
4710 if ($option_requires_value and defined ($2))
4711 #------------------------------------------------------------------------------
4712 # There is a value and it is passed on to the caller.
4713 #------------------------------------------------------------------------------
4720 return ($found_option, $option_value);
4722 } #-- End of subroutine find_target_option
4724 #------------------------------------------------------------------------------
4725 # Find the occurrences of non-space characters in a string and return their
4726 # start and end index values(s).
4727 #------------------------------------------------------------------------------
4728 sub find_words_in_line
4730 my $subr_name = get_my_name
();
4732 my ($input_line_ref) = @_;
4734 my $input_line = ${ $input_line_ref };
4736 my $finished = $TRUE;
4739 my $space_position = 0;
4743 my @word_delimiters = ();
4745 gp_message
("debugXL", $subr_name, "input_line = $input_line");
4748 while (not $finished)
4750 $space = index ($input_line, " ", $space_position);
4752 my $txt = "string search space_position = $space_position ";
4753 $txt .= "space = $space";
4754 gp_message
("debugXL", $subr_name, $txt);
4758 if ($space > $space_position)
4760 $start_word = $space_position;
4761 $end_word = $space - 1;
4762 $space_position = $space;
4763 my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
4764 gp_message
("debugXL", $subr_name, "string search start_word = $start_word end_word = $end_word space_position = $space_position $keyword");
4765 push (@word_delimiters, [$start_word, $end_word]);
4767 elsif ( ($space == $space_position) and ($space < length ($input_line) - 1))
4769 $space = $space + 1;
4770 $space_position = $space;
4776 gp_message
("debugXL", $subr_name, "completed - finished = $finished");
4782 $start_word = $space_position;
4783 $end_word = length ($input_line) - 1;
4784 my $keyword = substr ($input_line, $start_word, $end_word - $start_word + 1);
4785 push (@word_delimiters, [$start_word, $end_word]);
4786 if ($keyword =~ /\s+/)
4788 my $txt = "end search spaces only";
4789 gp_message
("debugXL", $subr_name, $txt);
4793 my $txt = "end search start_word = $start_word ";
4794 $txt .= "end_word = $end_word ";
4795 $txt .= "space_position = $space_position -->$keyword<--";
4796 gp_message
("debugXL", $subr_name, $txt);
4802 for my $i (keys @word_delimiters)
4804 gp_message
("debugXL", $subr_name, "i = $i $word_delimiters[$i][0] $word_delimiters[$i][1]");
4807 return (\
@word_delimiters);
4809 } #-- End of subroutine find_words_in_line
4811 #------------------------------------------------------------------------------
4813 #------------------------------------------------------------------------------
4816 my $subr_name = get_my_name
();
4818 my ($outputdir, $FUNC_FILE, $metric, $LINUX_vDSO_ref) = @_;
4820 my %LINUX_vDSO = %{ $LINUX_vDSO_ref };
4823 my $address_decimal;
4824 my $full_address_field;
4826 my $FUNC_FILE_NO_PC;
4827 my $off_with_the_PC;
4834 my %functions_per_metric_indexes = ();
4835 my %functions_per_metric_first_index = ();
4838 my ($line,$line_n,$value);
4839 my ($df_flag,$n,$u);
4840 my ($metric_value,$PC_Address,$routine);
4841 my ($is_calls,$metric_ok,$name_regex,$pc_len);
4842 my ($segment,$offset,$offy,$spaces,$rest,$not_printed,$vdso_key);
4844 #------------------------------------------------------------------------------
4845 # If the directory name does not end with a "/", add it.
4846 #------------------------------------------------------------------------------
4847 my $length_of_string = length ($outputdir);
4849 if (rindex ($outputdir, "/") != $length_of_string-1)
4854 gp_message
("debug", $subr_name, "on input FUNC_FILE = $FUNC_FILE metric = $metric");
4858 $off_with_the_PC = rindex ($FUNC_FILE, "-PC");
4859 $FUNC_FILE_NO_PC = substr ($FUNC_FILE, 0, $off_with_the_PC);
4861 if ($FUNC_FILE_NO_PC eq $outputdir."calls.sort.func")
4863 $FUNC_FILE_NO_PC = $outputdir."calls";
4865 $metric_ok = $FALSE;
4867 elsif ($FUNC_FILE_NO_PC eq $outputdir."calltree.sort.func")
4869 $FUNC_FILE_NO_PC = $outputdir."calltree";
4870 $metric_ok = $FALSE;
4872 elsif ($FUNC_FILE_NO_PC eq $outputdir."functions.sort.func")
4874 $FUNC_FILE_NO_PC = $outputdir."functions.func";
4875 $metric_ok = $FALSE;
4877 gp_message
("debugM", $subr_name, "set FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC");
4879 open (FUNC_FILE
, "<", $FUNC_FILE)
4880 or die ("Not able to open file $FUNC_FILE for reading - '$!'");
4881 gp_message
("debug", $subr_name, "opened file FUNC_FILE = $FUNC_FILE for reading");
4883 open (FUNC_FILE_NO_PC
, ">", $FUNC_FILE_NO_PC)
4884 or die ("Not able to open file $FUNC_FILE_NO_PC for writing - '$!'");
4885 gp_message
("debug", $subr_name, "opened file FUNC_FILE_NO_PC = $FUNC_FILE_NO_PC for writing");
4887 open (FUNC_FILE_REGEXP
, "<", "$FUNC_FILE.name-regex")
4888 or die ("Not able to open file $FUNC_FILE.name-regex for reading - '$!'");
4889 gp_message
("debug", $subr_name, "opened file FUNC_FILE_REGEXP = $FUNC_FILE.name-regex for reading");
4891 $name_regex = <FUNC_FILE_REGEXP
>;
4892 chomp ($name_regex);
4893 close (FUNC_FILE_REGEXP
);
4895 gp_message
("debugXL", $subr_name, "name_regex = $name_regex");
4901 #------------------------------------------------------------------------------
4902 # Note that the double \\ is needed here. The regex used will not have these.
4903 #------------------------------------------------------------------------------
4906 #------------------------------------------------------------------------------
4908 # I do not see the "*" in my test output, but no harm to leave the code in.
4910 # er_print * before PC for calls ! 101315
4911 #------------------------------------------------------------------------------
4912 $line_regex = "^(\\s*)(\\**)(\\S+)(:)(\\S+)(\\s+)(.*)";
4916 $line_regex = "^(\\s*)(\\S+)(:)(\\S+)(\\s+)(.*)";
4918 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." line_regex->$line_regex<-");
4919 gp_message
("debugXL", $subr_name, "read FUNC_FILE = $FUNC_FILE");
4928 # gp_message ("debug", $subr_name, "FUNC_FILE: input line = $line");
4931 if ($line =~ /$line_regex/) # field 2|3 needs to be \S in case of -ve sign
4933 #------------------------------------------------------------------------------
4934 # A typical target line looks like this:
4935 # 11:0x001492e0 6976.900 <additional_timings> _lwp_start
4936 #------------------------------------------------------------------------------
4937 gp_message
("debugXL", $subr_name, "select = $line");
4944 $PC_Address = $segment.$4.$offset; # PC Addr.
4945 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." \$3 = $3");
4946 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." \$5 = $5");
4947 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." \$6 = $6");
4948 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." \$7 = $7");
4956 $PC_Address = $segment.$3.$offset; # PC Addr.
4957 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." \$2 = $2");
4958 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." \$4 = $4");
4959 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." \$5 = $5");
4960 gp_message
("debugXL", $subr_name, "is_calls = ".(($is_calls) ?
"TRUE" : "FALSE")." \$6 = $6");
4964 #------------------------------------------------------------------------------
4965 # presume vDSO field overflow - er_print used an inadequate format
4966 # or the fsummary (MASTER) had the wrong format for -1?
4967 # rats - get ahead of ourselves - should not be a field abuttal so
4968 #------------------------------------------------------------------------------
4969 if ($line =~ /$name_regex/)
4973 $metric_value = $1; # whatever
4982 if (substr ($routine,0,1) eq "*")
4984 $routine = substr ($routine,1);
4987 for $vdso_key (keys %LINUX_vDSO)
4989 if ($routine eq $LINUX_vDSO{$vdso_key})
4991 #------------------------------------------------------------------------------
4992 # presume no duplicates - at least can check offset
4993 #------------------------------------------------------------------------------
4994 if ($vdso_key =~ /(\d+):(\S+)/)
4995 #------------------------------------------------------------------------------
4996 # no -ve segments allowed and not expected
4997 #------------------------------------------------------------------------------
5001 #------------------------------------------------------------------------------
5003 #------------------------------------------------------------------------------
5005 gp_message
("debugXL", $subr_name, "rescued segment for $PC_Address($routine)->$segment:$offset $FUNC_FILE");
5006 $PC_Address = $segment.":".$offset; # PC Addr.
5007 gp_message
("debugXL", $subr_name, "vdso line ->$line");
5008 $line = $PC_Address.(' ' x
(length ($spaces)-2)).$rest;
5009 gp_message
("debugXL", $subr_name, "becomes ->$line");
5018 gp_message
("debug", $subr_name, "name_regex failure for file $FUNC_FILE");
5022 #------------------------------------------------------------------------------
5023 # a rotten exception for Linux vDSO
5024 # With a BIG "PC Address" like 32767:0x841fecd0, the functions.sort.func_PC file
5025 # can have lines like
5026 #->32767:0x841fecd0161.553 527182898954 131.936 100003 __vdso_gettimeofday<-
5027 #->32767:0x153ff810 42.460 0 0 __vdso_gettimeofday<-
5028 #->-1:0xff600000 99.040 0 0 [vsyscall]<-
5029 # (Real PC Address: 4294967295:0xff600000)
5030 #-> 4294967295:0xff600000 99.040 0 0 [vsyscall]<-
5031 #-> 9:0x00000020 49.310 0 0 <static>@0x7fff153ff600 ([vdso])<-
5033 # $LINUX_vDSO{substr($order[$i]{"addressobjtext"},1)} = $order[$i]{"routine"};
5034 #------------------------------------------------------------------------------
5036 $not_printed = $TRUE;
5037 for $vdso_key (keys %LINUX_vDSO)
5039 if ($line =~ /^(\s*)($vdso_key)(.*)$/)
5043 $lblanks = length ($blanks);
5044 $lvdso_key = length ($vdso_key);
5045 $PC_Address = $vdso_key; # PC Addr.
5046 $offy = ($lblanks+$lvdso_key < $pc_len) ?
$pc_len : $lblanks+$lvdso_key;
5047 gp_message
("debugXL", $subr_name, "offy = $offy for ->$line<-");
5050 print FUNC_FILE_NO_PC
substr ($line,$offy)."\n";
5051 $not_printed = $FALSE;
5057 gp_message
("debugXL", $subr_name, "vdso line ->$line");
5058 if (substr ($line,$lblanks+$lvdso_key,1) eq " ")
5060 #------------------------------------------------------------------------------
5061 # O.K. no field abuttal
5062 #------------------------------------------------------------------------------
5063 gp_message
("debugXL", $subr_name, "vdso no field abuttal line ->$line");
5067 gp_message
("debugXL", $subr_name, "vdso field abuttal line ->$line");
5068 $line = $blanks.$vdso_key." ".$rest;
5070 gp_message
("debugXL", $subr_name, "becomes ->$line");
5078 print FUNC_FILE_NO_PC
substr ($line,$pc_len)."\n";
5084 $not_printed = $FALSE;
5091 if ($line =~ /(^\s*PC Addr.\s+)(\S+)/)
5093 $pc_len = length ($1); # say 15
5094 print FUNC_FILE_NO_PC
substr ($line,$pc_len)."\n";
5098 print FUNC_FILE_NO_PC
"$line\n";
5105 my $strlen = length ($line);
5108 print FUNC_FILE_NO_PC
substr ($line,$pc_len)."\n";
5112 print FUNC_FILE_NO_PC
"\n";
5123 if ($line =~ /$name_regex/)
5127 $metric_value = $1; # whatever
5138 if (substr ($routine,0,1) eq "*")
5140 $routine = substr ($routine,1);
5143 if (length ($routine))
5145 $order[$index_val]{"routine"} = $routine;
5148 $order[$index_val]{"metric_value"} = $metric_value;
5150 $order[$index_val]{"PC Address"} = $PC_Address;
5152 if (not exists ($functions_per_metric_indexes{$routine}))
5154 $functions_per_metric_indexes{$routine} = [$index_val];
5158 push (@
{$functions_per_metric_indexes{$routine}},$index_val); # add $RI to list
5160 gp_message
("debugXL", $subr_name, "updated functions_per_metric_indexes $routine [$index_val] line = $line");
5161 if ($PC_Address =~ /\s*(\S+):(\S+)/)
5163 my ($segment,$offset);
5166 $address_decimal = bigint
::hex ($offset); # decimal
5167 $full_address_field = '@'.$segment.":".$offset; # e.g. @2:0x0003f280
5168 $order[$index_val]{"addressobj"} = $address_decimal;
5169 $order[$index_val]{"addressobjtext"} = $full_address_field;
5171 #------------------------------------------------------------------------------
5173 #------------------------------------------------------------------------------
5174 if (not exists ($functions_per_metric_first_index{$routine}{$PC_Address}))
5176 $functions_per_metric_first_index{$routine}{$PC_Address} = $index_val;
5181 if (!($metric eq "calls" || $metric eq "calltree"))
5183 gp_message
("debug", $subr_name, "file $FUNC_FILE: function $routine already has a PC Address");
5188 gp_message
("debugXL", $subr_name, "updated index_val = $index_val");
5194 if ($n && length ($line))
5196 my $msg = "unexpected line format in functions file $FUNC_FILE line->$line<-";
5197 gp_message
("assertion", $subr_name, $msg);
5202 close (FUNC_FILE_NO_PC
);
5204 for my $i (sort keys %functions_per_metric_indexes)
5207 for my $fields (sort keys @
{ $functions_per_metric_indexes{$i} })
5209 $values .= "$functions_per_metric_indexes{$i}[$fields] ";
5211 gp_message
("debugXL", $subr_name, "on return: functions_per_metric_indexes{$i} = $values");
5214 return (\
@order, \
%functions_per_metric_first_index, \
%functions_per_metric_indexes);
5216 } #-- End of subroutine function_info
5218 #------------------------------------------------------------------------------
5219 # Generate a html header.
5220 #------------------------------------------------------------------------------
5221 sub generate_a_header
5223 my $subr_name = get_my_name
();
5225 my ($page_text_ref, $size_text_ref, $position_text_ref) = @_;
5227 my $page_text = ${ $page_text_ref };
5228 my $size_text = ${ $size_text_ref };
5229 my $position_text = ${ $position_text_ref };
5232 $html_header = "<div class=\"" . $position_text . "\">\n";
5233 $html_header .= "<". $size_text . ">\n";
5234 $html_header .= $page_text . "\n";
5235 $html_header .= "</". $size_text . ">\n";
5236 $html_header .= "</div>";
5238 gp_message
("debugXL", $subr_name, "on exit page_title = $html_header");
5240 return (\
$html_header);
5242 } #-- End of subroutine generate_a_header
5244 #------------------------------------------------------------------------------
5245 # Generate the caller-callee information.
5246 #------------------------------------------------------------------------------
5247 sub generate_caller_callee
5249 my $subr_name = get_my_name
();
5251 my ($number_of_metrics_ref, $function_info_ref, $function_view_structure_ref,
5252 $function_address_info_ref, $addressobjtextm_ref,
5253 $input_string_ref) = @_;
5255 my $number_of_metrics = ${ $number_of_metrics_ref };
5256 my @function_info = @
{ $function_info_ref };
5257 my %function_view_structure = %{ $function_view_structure_ref };
5258 my %function_address_info = %{ $function_address_info_ref };
5259 my %addressobjtextm = %{ $addressobjtextm_ref };
5260 my $input_string = ${ $input_string_ref };
5262 my @caller_callee_data = ();
5267 my $separator = "cuthere";
5269 my @address_field = ();
5271 my @function_names = ();
5273 my @metric_values = ();
5274 my @word_index_values = ();
5275 my @header_lines = ();
5278 my $elements_in_name;
5279 my $full_hex_address;
5286 my @html_metric_sort_header = ();
5288 my $html_title_header;
5290 my $html_acknowledgement;
5294 my $marker_target_function;
5295 my $max_metrics_length = 0;
5304 my $total_header_lines;
5305 my $word_index_values_ref;
5308 my $outputdir = append_forward_slash
($input_string);
5309 my $LANG = $g_locale_settings{"LANG"};
5310 my $decimal_separator = $g_locale_settings{"decimal_separator"};
5312 gp_message
("debug", $subr_name, "decimal_separator = $decimal_separator");
5313 gp_message
("debug", $subr_name, "outputdir = $outputdir");
5315 $infile = $outputdir . "caller-callee-PC2";
5316 $outfile = $outputdir . $g_html_base_file_name{"caller_callee"} . ".html";
5318 gp_message
("debug", $subr_name, "infile = $infile outfile = $outfile");
5320 open (CALLER_CALLEE_IN
, "<", $infile)
5321 or die ("unable to open caller file $infile for reading - '$!'");
5322 gp_message
("debug", $subr_name, "opened file $infile for reading");
5324 open (CALLER_CALLEE_OUT
, ">", $outfile)
5325 or die ("unable to open $outfile for writing - '$!'");
5326 gp_message
("debug", $subr_name, "opened file $outfile for writing");
5328 gp_message
("debug", $subr_name, "building caller-callee file $outfile");
5330 #------------------------------------------------------------------------------
5331 # Generate some of the structures used in the HTML output.
5332 #------------------------------------------------------------------------------
5333 $file_title = "Caller-callee overview";
5334 $html_header = ${ create_html_header
(\
$file_title) };
5335 $html_home = ${ generate_home_link
("right") };
5337 $page_title = "Caller Callee View";
5339 $position_text = "center";
5340 $html_title_header = ${ generate_a_header
(\
$page_title, \
$size_text, \
$position_text) };
5342 #------------------------------------------------------------------------------
5343 # Read all of the file into array with the name caller_callee_data.
5344 #------------------------------------------------------------------------------
5345 chomp (@caller_callee_data = <CALLER_CALLEE_IN
>);
5347 #------------------------------------------------------------------------------
5348 # Typical structure of the input file:
5350 # Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm
5351 # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
5352 # Functions sorted by metric: Exclusive Total CPU Time
5353 # Callers and callees sorted by metric: Attributed Total CPU Time
5355 # PC Addr. Name Attr. Attr. CPU Attr. Attr.
5356 # Total Cycles Instructions Last-Level
5357 # CPU sec. sec. Executed Cache Misses
5358 # 1:0x00000000 *<Total> 3.502 4.005 15396819700 24024250
5359 # 7:0x00008070 start_thread 3.342 3.865 14500538981 23824045
5360 # 6:0x000233a0 __libc_start_main 0.160 0.140 896280719 200205
5362 # PC Addr. Name Attr. Attr. CPU Attr. Attr.
5363 # Total Cycles Instructions Last-Level
5364 # CPU sec. sec. Executed Cache Misses
5365 # 2:0x000021f9 driver_mxv 3.342 3.865 14500538981 23824045
5366 # 2:0x000021ae *mxv_core 3.342 3.865 14500538981 23824045
5367 #------------------------------------------------------------------------------
5369 #------------------------------------------------------------------------------
5370 # Scan the input file. The first lines are assumed to be part of the header,
5371 # so we store those. The diagnostic lines that echo some settings are also
5372 # stored, but currently not used.
5373 #------------------------------------------------------------------------------
5374 my $scan_header = $FALSE;
5375 my $scan_caller_callee_data = $FALSE;
5376 my $data_function_block = "";
5377 my @function_blocks = ();
5379 my @html_caller_callee = ();
5380 my @top_level_header = ();
5382 #------------------------------------------------------------------------------
5384 #------------------------------------------------------------------------------
5385 my $empty_line_regex = '^\s*$';
5386 my $line_of_interest_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\**)(.*)';
5387 my $get_hex_address_regex = '(\d+):0x(\S+)';
5388 my $get_metric_field_regex = ')\s+([\s\d' . $decimal_separator . ']*)';
5389 my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)';
5390 my $sorted_by_regex = 'sorted by metric:';
5391 my $current_regex = '^Current';
5392 my $get_addr_offset_regex = '^@\d+:';
5394 #------------------------------------------------------------------------------
5395 # Get the length of the first metric field across all lines. This value is
5396 # used to pad the first metric with spaces and get the alignment right.
5398 # Scan the input data and find the line(s) with metric values. A complication
5399 # is that a function name may consists of more than one field.
5401 # Note. This part could be used to parse the other elements of the input file,
5402 # but that makes the loop very complicated. Instead, we re-scan the data
5403 # below and process each block separately.
5405 # Since this data is all in memory and relatively small, the performance should
5406 # not suffer much, but it does improve the readability of the code.
5407 #------------------------------------------------------------------------------
5408 gp_message
("debug", $subr_name, "determine the maximum length of the first field");
5410 $g_max_length_first_metric = 0;
5411 my @hex_addresses = ();
5412 my @special_marker = ();
5413 my @the_function_name = ();
5414 my @the_metrics = ();
5415 my @length_first_metric = ();
5417 for (my $line = 0; $line <= $#caller_callee_data; $line++)
5419 my $input_line = $caller_callee_data[$line];
5421 if ($input_line =~ /$line_of_interest_regex/)
5423 if (defined ($1) and defined ($2) and defined ($3))
5424 #------------------------------------------------------------------------------
5425 # This is a line of interest, since it has the address, the function name and
5426 # the values for the metrics. Examples of valid lines are:
5428 # 2:0x00005028 *xfree_large 0. 0
5429 # 12:0x0004c2b0 munmap 0.143 6402086
5430 # 7:0x0001b2df <static>@0x1b2df (<libgomp.so.1.0.0>) 0. 0
5432 # The function name marked with a * is the current target.
5433 #------------------------------------------------------------------------------
5435 my $full_hex_address = $1;
5437 my $remaining_line = $3;
5439 if ($full_hex_address =~ /$get_hex_address_regex/)
5441 $hex_address = "0x" . $2;
5442 push (@hex_addresses, $hex_address);
5443 gp_message
("debugXL", $subr_name, "pushed $hex_address");
5447 my $msg = "full_hex_address = $full_hex_address has an unknown format";
5448 gp_message
("assertion", $subr_name, $msg);
5452 push (@special_marker, "*");
5456 push (@special_marker, "X");
5461 my $msg = "input_line = $input_line has an unknown format";
5462 gp_message
("assertion", $subr_name, $msg);
5465 my @fields_in_line = split (" ", $input_line);
5467 #------------------------------------------------------------------------------
5468 # We stripped the address and marker (if any), off, so this string starts with
5469 # the function name.
5470 #------------------------------------------------------------------------------
5472 my $number_of_fields = scalar (@fields_in_line);
5473 my $words_in_function_name = $number_of_fields - $number_of_metrics - 1;
5474 my @remainder_array = split (" ", $remainder);
5476 #------------------------------------------------------------------------------
5477 # If the first metric is 0. (or 0, depending on the locale), the calculation
5478 # of the length needs to be adjusted, because 0. is really 0.000.
5480 # While we could easily add 3 to the length, we assign a symbolic value to the
5481 # first metric (ZZZ) and then compute the length. This makes things clearer.
5483 #------------------------------------------------------------------------------
5484 my $first_metric = $remainder_array[$words_in_function_name];
5485 if ($first_metric =~ /^0$decimal_separator$/)
5487 gp_message
("debugXL", $subr_name, "fixed up $first_metric");
5488 $first_metric = "0.ZZZ";
5490 push (@length_first_metric, length ($first_metric));
5492 my $txt = "words in function name = $words_in_function_name ";
5493 $txt .= "first_metric = $first_metric length = ";
5494 $txt .= length ($first_metric);
5495 gp_message
("debugXL", $subr_name, $txt);
5497 #------------------------------------------------------------------------------
5498 # Generate the regex for the metrics.
5500 # TBD: This should be an attribute of the function and be done once only.
5501 #------------------------------------------------------------------------------
5502 my $m_regex = '(\S+';
5503 for my $f (2 .. $words_in_function_name)
5505 $m_regex .= '\s+\S+';
5507 #------------------------------------------------------------------------------
5508 # This last part captures all the metric values.
5509 #------------------------------------------------------------------------------
5510 $m_regex .= $get_metric_field_regex;
5511 gp_message
("debugXL", $subr_name, "m_regex = $m_regex");
5512 gp_message
("debugXL", $subr_name, "remainder = $remainder");
5514 if ($remainder =~ /$m_regex/)
5517 my $its_metrics = $2;
5518 my $msg = "found the info - func_name = " . $func_name .
5519 " its metrics = " . $its_metrics;
5520 gp_message
("debugXL", $subr_name, $msg);
5522 push (@the_function_name, $func_name);
5523 push (@the_metrics, $its_metrics);
5527 my $msg = "remainder string $remainder has an unrecognized format";
5528 gp_message
("assertion", $subr_name, $msg);
5531 $g_max_length_first_metric = max
($g_max_length_first_metric, length ($first_metric));
5533 my $msg = "first_metric = $first_metric " .
5534 "g_max_length_first_metric = $g_max_length_first_metric";
5535 gp_message
("debugXL", $subr_name, $msg);
5538 gp_message
("debugXL", $subr_name, "final: g_max_length_first_metric = $g_max_length_first_metric");
5539 gp_message
("debugXL", $subr_name, "#hex_addresses = $#hex_addresses");
5541 #------------------------------------------------------------------------------
5542 # Main loop over the input data.
5543 #------------------------------------------------------------------------------
5544 my $index_start = 0; # 1
5545 my $index_end = -1; # 0
5546 for (my $line = 0; $line <= $#caller_callee_data; $line++)
5548 my $input_line = $caller_callee_data[$line];
5550 if ($input_line =~ /$header_name_regex/)
5552 $scan_header = $TRUE;
5553 gp_message
("debugXL", $subr_name, "line = $line encountered start of the header scan_header = $scan_header first = $first");
5555 elsif (($input_line =~ /$sorted_by_regex/) or ($input_line =~ /$current_regex/))
5557 my $msg = "line = " . $line . " captured top level header: " .
5558 "input_line = " . $input_line;
5559 gp_message
("debugXL", $subr_name, $msg);
5561 push (@top_level_header, $input_line);
5563 elsif ($input_line =~ /$line_of_interest_regex/)
5566 $scan_header = $FALSE;
5567 $scan_caller_callee_data = $TRUE;
5568 $data_function_block .= $separator . $input_line;
5570 my $msg = "line = $line updated index_end = $index_end";
5571 gp_message
("debugXL", $subr_name, $msg);
5573 elsif (($input_line =~ /$empty_line_regex/) and ($scan_caller_callee_data))
5575 #------------------------------------------------------------------------------
5576 # An empty line is interpreted as the end of the current block and we process
5577 # this, including the generation of the html code for this block.
5578 #------------------------------------------------------------------------------
5580 $scan_caller_callee_data = $FALSE;
5582 gp_message
("debugXL", $subr_name, "new block");
5583 gp_message
("debugXL", $subr_name, "line = $line index_start = $index_start");
5584 gp_message
("debugXL", $subr_name, "line = $line index_end = $index_end");
5585 gp_message
("debugXL", $subr_name, "line = $line data_function_block = $data_function_block");
5587 push (@function_blocks, $data_function_block);
5588 my ($html_block_prologue_ref, $html_code_function_block_ref) =
5589 generate_html_function_blocks
(
5594 \
@length_first_metric,
5596 \
@the_function_name,
5598 $number_of_metrics_ref,
5599 \
$data_function_block,
5601 $function_view_structure_ref);
5603 my @html_block_prologue = @
{ $html_block_prologue_ref };
5604 my @html_code_function_block = @
{ $html_code_function_block_ref };
5606 for my $lines (0 .. $#html_code_function_block)
5608 my $msg = "final html_code_function_block[" . $lines . "] = " .
5609 $html_code_function_block[$lines];
5610 gp_message
("debugXL", $subr_name, $msg);
5613 $data_function_block = "";
5615 push (@html_caller_callee, @html_block_prologue);
5616 push (@html_caller_callee, @header_lines);
5617 push (@html_caller_callee, @html_code_function_block);
5619 $index_start = $index_end + 1;
5620 $index_end = $index_start - 1;
5621 gp_message
("debugXL", $subr_name, "line = $line reset index_start = $index_start");
5622 gp_message
("debugXL", $subr_name, "line = $line reset index_end = $index_end");
5625 #------------------------------------------------------------------------------
5626 # Only capture the first header. They are all identical.
5627 #------------------------------------------------------------------------------
5628 if ($scan_header and $first)
5632 #------------------------------------------------------------------------------
5633 # This group is only defined for the first line of the header.
5634 #------------------------------------------------------------------------------
5635 gp_message
("debugXL", $subr_name, "header1 = $4");
5636 gp_message
("debugXL", $subr_name, "extra = $3 spaces=x$2x");
5637 my $newline = "<b>" . $4 . "</b>";
5638 push (@header_lines, $newline);
5640 elsif ($input_line =~ /\s*(.*)/)
5642 #------------------------------------------------------------------------------
5643 # Capture the subsequent header lines.
5644 #------------------------------------------------------------------------------
5645 gp_message
("debugXL", $subr_name, "headern = $1");
5646 my $newline = "<b>" . $1 . "</b>";
5647 push (@header_lines, $newline);
5653 for my $i (0 .. $#header_lines)
5655 gp_message
("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]");
5657 for my $i (0 .. $#function_blocks)
5659 gp_message
("debugXL", $subr_name, "function_blocks[$i] = $function_blocks[$i]");
5662 my $number_of_blocks = $#function_blocks + 1;
5663 gp_message
("debugXL", $subr_name, "There are " . $number_of_blocks . " function blocks:");
5665 for my $i (0 .. $#function_blocks)
5667 #------------------------------------------------------------------------------
5668 # The split produces an empty first field and is why we skip the first field.
5669 #------------------------------------------------------------------------------
5670 ## my @entries = split ("cuthere", $function_blocks[$i]);
5671 my @entries = split ($separator, $function_blocks[$i]);
5672 for my $k (1 .. $#entries)
5674 my $msg = "entries[" . $k . "] = ". $entries[$k];
5675 gp_message
("debugXL", $subr_name, $k . $msg);
5679 #------------------------------------------------------------------------------
5680 # Parse and process the individual function blocks.
5681 #------------------------------------------------------------------------------
5682 for my $i (0 .. $#function_blocks)
5684 my $msg = "function_blocks[" . $i . "] = ". $function_blocks[$i];
5685 gp_message
("debugXL", $subr_name, $msg);
5686 #------------------------------------------------------------------------------
5687 # This split produces an empty first field. This is why skip this.
5688 #------------------------------------------------------------------------------
5689 my @entries = split ($separator, $function_blocks[$i]);
5691 #------------------------------------------------------------------------------
5692 # An example of @entries:
5694 # 6:0x0003ad20 drand48 0.100 0.084 768240570 0
5695 # 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0
5696 # 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
5697 #------------------------------------------------------------------------------
5698 for my $k (1 .. $#entries)
5700 my $input_line = $entries[$k];
5702 my $msg = "input_line = entries[" . $k . "] = ". $entries[$k];
5703 gp_message
("debugXL", $subr_name, $msg);
5705 @fields = split (" ", $input_line);
5707 $no_of_fields = $#fields + 1;
5708 $elements_in_name = $no_of_fields - $number_of_metrics - 1;
5710 #------------------------------------------------------------------------------
5711 # TBD: Too restrictive.
5712 # CHECK CODE IN GENERATE_CALLER_CALLEE
5713 #------------------------------------------------------------------------------
5714 if ($elements_in_name == 1)
5716 $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])(\S+)\s+(.*)';
5718 elsif ($elements_in_name == 2)
5720 $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+([\s\*])((\S+)\s+(\S+))\s+(.*)';
5723 #------------------------------------------------------------------------------
5724 # TBD: Handle this better in case a function entry has more than 2 words.
5725 #------------------------------------------------------------------------------
5727 my $msg = "$elements_in_name elements in name exceeds limit";
5728 gp_message
("assertion", $subr_name, $msg);
5731 if ($input_line =~ /$name_regex/)
5733 $full_hex_address = $1;
5734 $marker_target_function = $2;
5736 if ($elements_in_name == 1)
5740 elsif ($elements_in_name == 2)
5745 $metrics_length = length ($all_metrics);
5746 $max_metrics_length = max
($max_metrics_length, $metrics_length);
5748 if ($full_hex_address =~ /(\d+):0x(\S+)/)
5750 $hex_address = "0x" . $2;
5752 push (@marker, $marker_target_function);
5753 push (@address_field, $hex_address);
5754 $modified_line = $all_metrics . " " . $routine;
5755 push (@metric_values, $all_metrics);
5756 gp_message
("debugXL", $subr_name, "xxxxxxx = $modified_line");
5757 push (@function_names, $routine);
5761 $total_header_lines = $#header_lines + 1;
5762 gp_message
("debugXL", $subr_name, "total_header_lines = $total_header_lines");
5764 gp_message
("debugXL", $subr_name, "Final output");
5765 for my $i (keys @header_lines)
5767 gp_message
("debugXL", $subr_name, "$header_lines[$i]");
5769 for my $i (0 .. $#function_names)
5771 my $msg = $metric_values[$i] . " " . $marker[$i] .
5772 $function_names[$i] . "(" . $address_field[$i] . ")";
5773 gp_message
("debugXL", $subr_name, $msg);
5775 #------------------------------------------------------------------------------
5776 # Check if this function has multiple occurrences.
5777 # TBD: Replace by the function call for this.
5778 #------------------------------------------------------------------------------
5779 gp_message
("debugXL", $subr_name, "check for multiple occurrences");
5780 for my $i (0 .. $#function_names)
5782 my $current_address = $address_field[$i];
5786 $routine = $function_names[$i];
5787 $alt_name = $routine;
5788 gp_message
("debugXL", $subr_name, "checking for routine = $routine");
5789 if (exists ($g_multi_count_function{$routine}))
5792 #------------------------------------------------------------------------------
5793 # TBD: Scan all of the function_info list. Or beter: add index to g_multi_count_function!!
5794 #------------------------------------------------------------------------------
5796 $found_a_match = $FALSE;
5797 gp_message
("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
5798 for my $ref (keys @
{ $g_map_function_to_index{$routine} })
5800 $ref_index = $g_map_function_to_index{$routine}[$ref];
5802 gp_message
("debugXL", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
5803 gp_message
("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
5805 my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
5806 gp_message
("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
5808 $addr_offset =~ s/$get_addr_offset_regex//;
5809 gp_message
("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
5810 if ($addr_offset eq $current_address)
5812 $found_a_match = $TRUE;
5816 gp_message
("debugXL", $subr_name, "$function_info[$ref_index]{'alt_name'} is the actual function for i = $i $found_a_match");
5817 $alt_name = $function_info[$ref_index]{'alt_name'};
5819 gp_message
("debugXL", $subr_name, "alt_name = $alt_name");
5821 gp_message
("debugXL", $subr_name, "completed check for multiple occurrences");
5823 #------------------------------------------------------------------------------
5824 # Figure out the column width. Since the columns in the header may include
5825 # spaces, we use the first line with metrics for this.
5826 #------------------------------------------------------------------------------
5827 my $top_header = $metric_values[0];
5828 my $word_index_values_ref = find_words_in_line
(\
$top_header);
5829 my @word_index_values = @
{ $word_index_values_ref };
5835 for my $i (keys @word_index_values)
5837 gp_message
("debugXL", $subr_name, "i = $i $word_index_values[$i][0] $word_index_values[$i][1]");
5841 push (@html_metric_sort_header, "<i>");
5842 for my $i (0 .. $#top_level_header)
5844 $html_line = $top_level_header[$i] . "<br>";
5845 push (@html_metric_sort_header, $html_line);
5847 push (@html_metric_sort_header, "</i>");
5849 print CALLER_CALLEE_OUT
$html_header;
5850 print CALLER_CALLEE_OUT
$html_home;
5851 print CALLER_CALLEE_OUT
$html_title_header;
5852 print CALLER_CALLEE_OUT
"$_" for @g_html_experiment_stats;
5853 ## print CALLER_CALLEE_OUT "<br>\n";
5854 ## print CALLER_CALLEE_OUT "$_\n" for @html_metric_sort_header;
5855 print CALLER_CALLEE_OUT
"<pre>\n";
5856 print CALLER_CALLEE_OUT
"$_\n" for @html_caller_callee;
5857 print CALLER_CALLEE_OUT
"</pre>\n";
5859 #------------------------------------------------------------------------------
5860 # Get the acknowledgement, return to main link, and final html statements.
5861 #------------------------------------------------------------------------------
5862 $html_home = ${ generate_home_link
("left") };
5863 $html_acknowledgement = ${ create_html_credits
() };
5864 $html_end = ${ terminate_html_document
() };
5866 print CALLER_CALLEE_OUT
$html_home;
5867 print CALLER_CALLEE_OUT
"<br>\n";
5868 print CALLER_CALLEE_OUT
$html_acknowledgement;
5869 print CALLER_CALLEE_OUT
$html_end;
5871 close (CALLER_CALLEE_OUT
);
5875 } #-- End of subroutine generate_caller_callee
5877 #------------------------------------------------------------------------------
5878 # Generate the html version of the disassembly file.
5880 # Note to self (TBD)
5881 # https://community.intel.com/t5/Intel-oneAPI-AI-Analytics/bd-p/ai-analytics-toolkit
5882 #------------------------------------------------------------------------------
5883 sub generate_dis_html
5885 my $subr_name = get_my_name
();
5887 my ($target_function_ref, $number_of_metrics_ref, $function_info_ref,
5888 $function_address_and_index_ref, $outputdir_ref, $func_ref,
5889 $source_line_ref, $metric_ref, $addressobj_index_ref) = @_;
5891 my $target_function = ${ $target_function_ref };
5892 my $number_of_metrics = ${ $number_of_metrics_ref };
5893 my @function_info = @
{ $function_info_ref };
5894 my %function_address_and_index = %{ $function_address_and_index_ref };
5895 my $outputdir = ${ $outputdir_ref };
5896 my $func = ${ $func_ref };
5897 my @source_line = @
{ $source_line_ref };
5898 my @metric = @
{ $metric_ref };
5899 my %addressobj_index = %{ $addressobj_index_ref };
5901 my $dec_instruction_start;
5902 my $dec_instruction_end;
5903 my $hex_instruction_start;
5904 my $hex_instruction_end;
5906 my @colour_line = ();
5910 my $dec_instr_address;
5914 my $html_new_line = "<br>";
5915 my $add_new_line_before;
5916 my $add_new_line_after;
5920 my $filename = $func;
5922 my $orig_hex_instr_address;
5923 my $hex_instr_address;
5929 my $last_address_in_hex;
5936 my $branch_regex = $g_arch_specific_settings{"regex"};
5937 my $convert_to_dot = $g_locale_settings{"convert_to_dot"};
5938 my $decimal_separator = $g_locale_settings{"decimal_separator"};
5939 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
5940 my $linksubexp = $g_arch_specific_settings{"linksubexp"};
5941 my $subexp = $g_arch_specific_settings{"subexp"};
5945 my %branch_target = ();
5946 my %branch_target_no_ref = ();
5947 my @disassembly_file = ();
5948 my %extended_branch_target = ();
5949 my %inverse_branch_target = ();
5951 my @modified_html = ();
5953 my $branch_target_ref;
5954 my $extended_branch_target_ref;
5955 my $branch_target_no_ref_ref;
5958 my $dec_branch_address;
5961 my $func_name_in_dis_file;
5962 my $hex_branch_target;
5963 my $instruction_address;
5964 my $instruction_offset;
5967 my $raw_hex_branch_target;
5970 my $html_dis_out = $func . ".html";
5972 #------------------------------------------------------------------------------
5973 # The regex section.
5974 #------------------------------------------------------------------------------
5975 my $call_regex = '.*([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)';
5976 my $line_of_interest_regex = '^#*\s+([\d' . $decimal_separator . '\s+]+)\[\s*(\d+|\?)\]';
5977 my $white_space_regex = '\s+';
5978 my $first_integer_regex = '^\d+$';
5979 my $integer_regex = '\d+';
5980 my $qmark_regex = '\?';
5981 my $src_regex = '(\s*)(\d+)\.(.*)';
5982 my $function_regex = '^(\s*)<Function:\s(.*)>';
5983 my $end_src_header_regex = "(^\\s+)(\\d+)\\.\\s+(.*)";
5984 my $end_dis_header_regex = "(^\\s+)(<Function: )(.*)>";
5985 my $control_flow_1_regex = 'j[a-z]+';
5986 my $control_flow_2_regex = 'call';
5987 my $control_flow_3_regex = 'ret';
5989 ## my $function_call_regex2 = '(.*)\s+([0-9a-fA-F]*):\s+(call)\s*0x([0-9a-fA-F]+)\s*';
5990 ## my $endbr_regex = '\.*([0-9a-fA-F]*):\s+(endbr[32|64])';
5991 #------------------------------------------------------------------------------
5992 # Dynamic. Computed below.
5994 # TBD: Try to move these up.
5995 #------------------------------------------------------------------------------
5999 gp_message
("debug", $subr_name, "g_branch_regex = $g_branch_regex");
6000 gp_message
("debug", $subr_name, "call_regex = $call_regex");
6001 gp_message
("debug", $subr_name, "g_function_call_v2_regex = $g_function_call_v2_regex");
6003 my $the_title = set_title
($function_info_ref, $func, "disassembly");
6005 gp_message
("debug", $subr_name, "the_title = $the_title");
6007 $file_title = $the_title;
6008 $html_header = ${ create_html_header
(\
$file_title) };
6009 $html_home = ${ generate_home_link
("right") };
6011 push (@modified_html, $html_header);
6012 push (@modified_html, $html_home);
6013 push (@modified_html, "<pre>");
6015 #------------------------------------------------------------------------------
6016 # Open the input and output files.
6017 #------------------------------------------------------------------------------
6018 open (INPUT_DISASSEMBLY
, "<", $filename)
6019 or die ("$subr_name - unable to open disassembly file $filename for reading: '$!'");
6020 gp_message
("debug", $subr_name , "opened file $filename for reading");
6022 open (HTML_OUTPUT
, ">", $html_dis_out)
6023 or die ("$subr_name - unable to open file $html_dis_out for writing: '$!'");
6024 gp_message
("debug", $subr_name , "opened file $html_dis_out for writing");
6026 #------------------------------------------------------------------------------
6027 # Check if the file is empty
6028 #------------------------------------------------------------------------------
6029 $file_is_empty = is_file_empty
($filename);
6033 #------------------------------------------------------------------------------
6034 # The input file is empty. Write a message in the html file and exit.
6035 #------------------------------------------------------------------------------
6036 gp_message
("debug", $subr_name ,"file $filename is empty");
6038 my $comment = "No disassembly generated by $tool_name - file $filename is empty";
6039 my $gp_error_file = $outputdir . "gp-listings.err";
6041 my $html_empty_file_ref = html_text_empty_file
(\
$comment, \
$gp_error_file);
6042 my @html_empty_file = @
{ $html_empty_file_ref };
6044 print HTML_OUTPUT
"$_\n" for @html_empty_file;
6046 close (HTML_OUTPUT
);
6048 return (\
@source_line);
6053 #------------------------------------------------------------------------------
6054 # Read the file into memory.
6055 #------------------------------------------------------------------------------
6056 chomp (@disassembly_file = <INPUT_DISASSEMBLY
>);
6057 gp_message
("debug", $subr_name ,"read file $filename into memory");
6060 my $max_length_first_metric = 0;
6063 #------------------------------------------------------------------------------
6064 # First scan through the assembly listing.
6065 #------------------------------------------------------------------------------
6066 for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++)
6068 my $input_line = $disassembly_file[$line_no];
6069 gp_message
("debugXL", $subr_name, "[line $line_no] $input_line");
6071 if ($input_line =~ /$line_of_interest_regex/)
6074 #------------------------------------------------------------------------------
6075 # Found a matching line. Examples are:
6076 # 0.370 [37] 4021d1: addsd %xmm0,%xmm1
6077 # ## 1.001 [36] 4021d5: add $0x1,%rax
6078 #------------------------------------------------------------------------------
6079 gp_message
("debugXL", $subr_name, "selected line \$1 = $1 \$2 = $2");
6081 if (defined ($2) and defined($1))
6083 @metrics = split (/$white_space_regex/ ,$1);
6088 my $msg = "$input_line has an unexpected format";
6089 gp_message
("assertion", $subr_name, $msg);
6092 #------------------------------------------------------------------------------
6093 # Compute the maximum length of the first metric and pad the field from the
6094 # left later on. The fractional part is ignored.
6095 #------------------------------------------------------------------------------
6096 my $first_metric = $metrics[0];
6098 if ($first_metric =~ /$first_integer_regex/)
6100 $new_length = length ($first_metric);
6104 my @fields = split (/$decimal_separator/, $first_metric);
6105 $new_length = length ($fields[0]);
6107 $max_length_first_metric = max
($max_length_first_metric, $new_length);
6109 $msg = "first_metric = $first_metric " .
6110 "max_length_first_metric = $max_length_first_metric";
6111 gp_message
("debugXL", $subr_name, $msg);
6113 if ($src_line_no !~ /$qmark_regex/)
6114 #------------------------------------------------------------------------------
6115 # The source code line number is known and is stored.
6116 #------------------------------------------------------------------------------
6118 $source_line[$line_no] = $src_line_no;
6120 $msg = "found an instruction with a source line ref:";
6121 $msg .= " source_line[$line_no] = $source_line[$line_no]";
6122 gp_message
("debugXL", $subr_name, $msg);
6125 #------------------------------------------------------------------------------
6126 # Check for function calls. If found, get the address offset from $4 and
6127 # compute the target address.
6128 #------------------------------------------------------------------------------
6129 ($found_it_ref, $branch_target_ref, $extended_branch_target_ref) =
6130 check_and_proc_dis_func_call
(
6134 \
%extended_branch_target);
6135 $found_it = ${ $found_it_ref };
6139 %branch_target = %{ $branch_target_ref };
6140 %extended_branch_target = %{ $extended_branch_target_ref };
6143 #------------------------------------------------------------------------------
6144 # Look for a branch instruction, or the special endbr32/endbr64 instruction
6145 # that is also considered to be a branch target. Note that the latter is x86
6147 #------------------------------------------------------------------------------
6148 ($found_it_ref, $branch_target_ref, $extended_branch_target_ref,
6149 $branch_target_no_ref_ref) = check_and_proc_dis_branches
(
6153 \
%extended_branch_target,
6154 \
%branch_target_no_ref);
6155 $found_it = ${ $found_it_ref };
6159 %branch_target = %{ $branch_target_ref };
6160 %extended_branch_target = %{ $extended_branch_target_ref };
6161 %branch_target_no_ref = %{ $branch_target_no_ref_ref };
6164 } #-- End of loop over line_no
6166 %inverse_branch_target = reverse (%extended_branch_target);
6168 gp_message
("debug", $subr_name, "generated inverse of branch target structure");
6169 gp_message
("debug", $subr_name, "completed parsing file $filename");
6171 for my $key (sort keys %branch_target)
6173 gp_message
("debug", $subr_name, "branch_target{$key} = $branch_target{$key}");
6175 for my $key (sort keys %extended_branch_target)
6177 gp_message
("debug", $subr_name, "extended_branch_target{$key} = $extended_branch_target{$key}");
6179 for my $key (sort keys %inverse_branch_target)
6181 gp_message
("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}");
6183 for my $key (sort keys %branch_target_no_ref)
6185 gp_message
("debug", $subr_name, "branch_target_no_ref{$key} = $branch_target_no_ref{$key}");
6186 $inverse_branch_target{$key} = $key;
6188 for my $key (sort keys %inverse_branch_target)
6190 gp_message
("debug", $subr_name, "inverse_branch_target{$key} = $inverse_branch_target{$key}");
6193 #------------------------------------------------------------------------------
6194 # Process the disassembly.
6195 #------------------------------------------------------------------------------
6197 #------------------------------------------------------------------------------
6198 # Dynamically generate the regexes.
6199 #------------------------------------------------------------------------------
6201 for my $metric_used (1 .. $number_of_metrics)
6203 $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+';
6206 $dis_regex = '^(#{2}|\s{2})\s+';
6207 $dis_regex .= '(.*)';
6208 ## $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)\s+(.*)';
6209 $dis_regex .= '\[\s*([0-9?]+)\]\s+([0-9a-fA-F]+):\s+([a-z0-9]+)(.*)';
6211 gp_message
("debugXL", $subr_name, "metric_regex = $metric_regex");
6212 gp_message
("debugXL", $subr_name, "dis_regex = $dis_regex");
6213 gp_message
("debugXL", $subr_name, "src_regex = $src_regex");
6214 gp_message
("debugXL", $subr_name, "contents of lines array");
6216 #------------------------------------------------------------------------------
6217 # Identify the header lines. Make the minimal assumptions.
6219 # In both cases, the first line after the header has whitespace. This is
6222 # - A source line file has "<line_no>."
6223 # - A dissasembly file has "<Function:"
6225 # These are the characteristics we use below.
6226 #------------------------------------------------------------------------------
6227 for (my $line_no=0; $line_no <= $#disassembly_file; $line_no++)
6229 my $input_line = $disassembly_file[$line_no];
6230 gp_message
("debugXL", $subr_name, "[line $line_no] $input_line");
6232 if ($input_line =~ /$end_src_header_regex/)
6234 gp_message
("debugXL", $subr_name, "header time is over - hit source line\n");
6235 gp_message
("debugXL", $subr_name, "$1 $2 $3\n");
6238 if ($input_line =~ /$end_dis_header_regex/)
6240 gp_message
("debugXL", $subr_name, "header time is over - hit disassembly line\n");
6243 push (@modified_html, "<i>" . $input_line . "</i>");
6245 my $line_index = scalar (@modified_html);
6246 gp_message
("debugXL", $subr_name, "final line_index = $line_index");
6248 for (my $line_no=0; $line_no <= $line_index-1; $line_no++)
6250 my $msg = " modified_html[$line_no] = $modified_html[$line_no]";
6251 gp_message
("debugXL", $subr_name, $msg);
6254 #------------------------------------------------------------------------------
6256 # 20. for (int64_t r=0; r<repeat_count; r++) {
6259 # 0.340 [37] 401fec: addsd %xmm0,%xmm1
6260 # ## 1.311 [36] 401ff0: addq $1,%rax
6261 #------------------------------------------------------------------------------
6263 #------------------------------------------------------------------------------
6264 # Find the hot PCs and store them.
6265 #------------------------------------------------------------------------------
6266 my @hot_program_counters = ();
6267 my @transposed_hot_pc = ();
6268 my @max_metric_values = ();
6270 gp_message
("debug", $subr_name, "determine the maximum metric values");
6271 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
6273 my $input_line = $disassembly_file[$line_no];
6275 if ( $input_line =~ /$dis_regex/ )
6277 ## if ( defined ($1) and defined ($2) and defined ($3) and
6278 ## defined ($4) and defined ($5) and defined ($6) )
6279 if ( defined ($1) and defined ($2) and defined ($3) and
6280 defined ($4) and defined ($5) )
6283 $metric_values = $2;
6285 $dec_instr_address = bigint
::hex ($4);
6289 my $white_space_regex = '\s*';
6291 $operands =~ s/$white_space_regex//;
6294 if ($hot_line eq "##")
6296 my @metrics = split (" ", $metric_values);
6297 push (@hot_program_counters, [@metrics]);
6302 for my $row (keys @hot_program_counters)
6304 my $msg = "$filename row[" . $row . "] =";
6305 for my $col (keys @
{$hot_program_counters[$row]})
6307 $msg .= " $hot_program_counters[$row][$col]";
6308 $transposed_hot_pc[$col][$row] = $hot_program_counters[$row][$col];
6310 gp_message
("debugXL", $subr_name, "hot PC = $msg");
6312 for my $row (keys @transposed_hot_pc)
6314 my $msg = "$filename row[" . $row . "] =";
6315 for my $col (keys @
{$transposed_hot_pc[$row]})
6317 $msg .= " $transposed_hot_pc[$row][$col]";
6319 gp_message
("debugXL", $subr_name, "$filename transposed = $msg");
6321 #------------------------------------------------------------------------------
6322 # Get the maximum metric values and if integer, convert to floating-point.
6323 # Since it is easier, we transpose the array and access it over the columns.
6324 #------------------------------------------------------------------------------
6325 for my $row (0 .. $#transposed_hot_pc)
6328 for my $col (0 .. $#{$transposed_hot_pc[$row]})
6330 $max_val = max
($transposed_hot_pc[$row][$col], $max_val);
6332 if ($max_val =~ /$integer_regex/)
6334 $max_val = sprintf ("%f", $max_val);
6336 gp_message
("debugXL", $subr_name, "$filename row = $row max_val = $max_val");
6337 push (@max_metric_values, $max_val);
6340 for my $metric (0 .. $#max_metric_values)
6342 my $msg = "$filename maximum[$metric] = $max_metric_values[$metric]";
6343 gp_message
("debugM", $subr_name, $msg);
6346 #------------------------------------------------------------------------------
6347 # TBD - Integrate this better.
6349 # Scan the instructions to find the instruction address range. This is used
6350 # to determine if a branch is external to this function.
6351 #------------------------------------------------------------------------------
6352 $dec_instruction_start = undef;
6353 $dec_instruction_end = undef;
6354 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
6356 my $input_line = $disassembly_file[$line_no];
6357 if ( $input_line =~ /$dis_regex/ )
6359 # if ( defined ($1) and defined ($2) and defined ($3) and
6360 ## defined ($4) and defined ($5) and defined ($6) )
6361 if ( defined ($1) and defined ($2) and defined ($3) and
6362 defined ($4) and defined ($5) )
6365 $metric_values = $2;
6367 $dec_instr_address = bigint
::hex ($4);
6372 my $white_space_regex = '\s*';
6374 $operands =~ s/$white_space_regex//;
6377 if (defined ($dec_instruction_start))
6379 if ($dec_instr_address < $dec_instruction_start)
6381 $dec_instruction_start = $dec_instr_address;
6386 $dec_instruction_start = $dec_instr_address;
6388 if (defined ($dec_instruction_end))
6390 if ($dec_instr_address > $dec_instruction_end)
6392 $dec_instruction_end = $dec_instr_address;
6397 $dec_instruction_end = $dec_instr_address;
6403 if (defined ($dec_instruction_start) and defined ($dec_instruction_end))
6405 $hex_instruction_start = sprintf ("%x", $dec_instruction_start);
6406 $hex_instruction_end = sprintf ("%x", $dec_instruction_end);
6409 $msg = "$filename $func dec_instruction_start = " .
6410 "$dec_instruction_start (0x$hex_instruction_start)";
6411 gp_message
("debugXL", $subr_name, $msg);
6412 $msg = "$filename $func dec_instruction_end = " .
6413 "$dec_instruction_end (0x$hex_instruction_end)";
6414 gp_message
("debugXL", $subr_name, $msg);
6417 #------------------------------------------------------------------------------
6418 # This is where all the results from above come together.
6419 #------------------------------------------------------------------------------
6420 for (my $line_no=$line_index-1; $line_no <= $#disassembly_file; $line_no++)
6422 my $input_line = $disassembly_file[$line_no];
6423 gp_message
("debugXL", $subr_name, "input_line[$line_no] = $input_line");
6424 if ( $input_line =~ /$dis_regex/ )
6426 gp_message
("debugXL", $subr_name, "found a disassembly line: $input_line");
6428 if ( defined ($1) and defined ($2) and defined ($3) and
6429 defined ($4) and defined ($5) )
6431 # $branch_target{$hex_branch_target} = 1;
6432 # $extended_branch_target{$instruction_address} = $raw_hex_branch_target;
6434 $metric_values = $2;
6436 $orig_hex_instr_address = $4;
6440 my $msg = "disassembly line: $1 $2 $3 $4 $5";
6443 $msg .= " \$6 = $6";
6444 my $white_space_regex = '\s*';
6446 $operands =~ s/$white_space_regex//;
6448 gp_message
("debugXL", $subr_name, $msg);
6450 #------------------------------------------------------------------------------
6451 # Pad the line with the metrics to ensure correct alignment.
6452 #------------------------------------------------------------------------------
6454 my @split_metrics = split (" ", $metric_values);
6455 my $first_metric = $split_metrics[0];
6456 ## if ($first_metric =~ /^\d+$/)
6457 if ($first_metric =~ /$first_integer_regex/)
6459 $the_length = length ($first_metric);
6463 my @fields = split (/$decimal_separator/, $first_metric);
6464 $the_length = length ($fields[0]);
6466 my $spaces = $max_length_first_metric - $the_length;
6468 for my $p (1 .. $spaces)
6472 $metric_values = $pad . $metric_values;
6473 gp_message
("debugXL", $subr_name, "pad = $pad");
6474 gp_message
("debugXL", $subr_name, "metric_values = $metric_values");
6476 #------------------------------------------------------------------------------
6477 # Since the instruction address variable may change and because we need the
6478 # original address without html controls, we use a new variable for the
6479 # (potentially) modified address.
6480 #------------------------------------------------------------------------------
6481 $hex_instr_address = $orig_hex_instr_address;
6482 $add_new_line_before = $FALSE;
6483 $add_new_line_after = $FALSE;
6485 if ($src_line eq "?")
6487 #------------------------------------------------------------------------------
6488 # There is no source line number. Do not add a link.
6489 #------------------------------------------------------------------------------
6491 $modified_line = $hot_line . ' ' . $metric_values . ' [' . $src_line . '] ';
6492 gp_message
("debugXL", $subr_name, "initialized modified_line = $modified_line");
6496 #------------------------------------------------------------------------------
6497 # There is a source line number. Mark it as link.
6498 #------------------------------------------------------------------------------
6499 $src_line_ref = "[<a href='#line_".$src_line."'>".$src_line."</a>]";
6500 gp_message
("debugXL", $subr_name, "src_line_ref = $src_line_ref");
6501 gp_message
("debugXL", $subr_name, "hex_instr_address = $hex_instr_address");
6503 $modified_line = $hot_line . ' ' . $metric_values . ' ' . $src_line_ref . ' ';
6504 gp_message
("debugXL", $subr_name, "initialized modified_line = $modified_line");
6507 #------------------------------------------------------------------------------
6508 # Mark control flow instructions. Several cases need to be distinguished.
6510 # In all cases we give the instruction a specific color, mark it boldface
6511 # and add a new-line after the instruction
6512 #------------------------------------------------------------------------------
6513 if ( ($instruction =~ /$control_flow_1_regex/) or
6514 ($instruction =~ /$control_flow_2_regex/) or
6515 ($instruction =~ /$control_flow_3_regex/) )
6517 gp_message
("debugXL", $subr_name, "instruction = $instruction is a control flow instruction");
6519 $add_new_line_after = $TRUE;
6522 $instruction = color_string
($instruction, $boldface, $g_html_color_scheme{"control_flow"});
6525 if (exists ($extended_branch_target{$hex_instr_address}))
6526 #------------------------------------------------------------------------------
6527 # This is a branch instruction and we need to add the target address.
6529 # In case the target address is outside of this load object, the link is
6530 # colored differently.
6532 # TBD: Add the name and if possible, a working link to this code.
6533 #------------------------------------------------------------------------------
6535 $branch_address = $extended_branch_target{$hex_instr_address};
6537 $dec_branch_address = bigint
::hex ($branch_address);
6539 if ( ($dec_branch_address >= $dec_instruction_start) and
6540 ($dec_branch_address <= $dec_instruction_end) )
6541 #------------------------------------------------------------------------------
6542 # The instruction is within the range.
6543 #------------------------------------------------------------------------------
6545 $link = "[ <a href='#".$branch_address."'>".$branch_address."</a> ]";
6549 #------------------------------------------------------------------------------
6550 # The instruction is outside of the range. Change the color of the link.
6551 #------------------------------------------------------------------------------
6552 gp_message
("debugXL", $subr_name, "address is outside of range");
6554 $link = "[ <a href='#".$branch_address;
6555 $link .= "' style='color:$g_html_color_scheme{'link_outside_range'}'>";
6556 $link .= $branch_address."</a> ]";
6558 gp_message
("debugXL", $subr_name, "address exists new link = $link");
6560 $operands .= ' ' . $link;
6561 gp_message
("debugXL", $subr_name, "update #1 modified_line = $modified_line");
6563 if (exists ($branch_target_no_ref{$hex_instr_address}))
6565 gp_message
("debugXL", $subr_name, "NEWBR branch_target_no_ref{$hex_instr_address} = $branch_target_no_ref{$hex_instr_address}");
6567 ## if (exists ($inverse_branch_target{$hex_instr_address}) or
6568 ## exists ($branch_target_no_ref{$hex_instr_address}))
6569 if (exists ($inverse_branch_target{$hex_instr_address}))
6570 #------------------------------------------------------------------------------
6571 # This is a target address and we need to define the instruction address to be
6573 #------------------------------------------------------------------------------
6575 $add_new_line_before = $TRUE;
6577 my $branch_target = $inverse_branch_target{$hex_instr_address};
6578 my $target = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>:";
6579 gp_message
("debugXL", $subr_name, "inverse exists - hex_instr_address = $hex_instr_address");
6580 gp_message
("debugXL", $subr_name, "inverse exists - add a target target = $target");
6582 $hex_instr_address = "<a name='".$hex_instr_address."'><b>".$hex_instr_address."</b></a>";
6583 gp_message
("debugXL", $subr_name, "update #2 hex_instr_address = $hex_instr_address");
6584 gp_message
("debugXL", $subr_name, "update #2 modified_line = $modified_line");
6587 $modified_line .= $hex_instr_address . ': ' . $instruction . ' ' . $operands;
6589 gp_message
("debugXL", $subr_name, "final modified_line = $modified_line");
6591 #------------------------------------------------------------------------------
6592 # This is a control flow instruction, but it is the last one and we do not
6593 # want to add a newline.
6594 #------------------------------------------------------------------------------
6595 gp_message
("debugXL", $subr_name, "decide where the <br> should go in the html");
6596 gp_message
("debugXL", $subr_name, "add_new_line_after = $add_new_line_after");
6597 gp_message
("debugXL", $subr_name, "add_new_line_before = $add_new_line_before");
6599 if ( $add_new_line_after and ($orig_hex_instr_address eq $hex_instruction_end) )
6601 $add_new_line_after = $FALSE;
6602 gp_message
("debugXL", $subr_name, "$instruction is the last instruction - do not add a newline");
6605 if ($add_new_line_before)
6608 #------------------------------------------------------------------------------
6609 # Get the previous line, if any, so that we can check what it is.
6610 #------------------------------------------------------------------------------
6611 my $prev_line = pop (@modified_html);
6612 if ( defined ($prev_line) )
6614 gp_message
("debugXL", $subr_name, "prev_line = $prev_line");
6616 #------------------------------------------------------------------------------
6617 # Restore the previously popped line.
6618 #------------------------------------------------------------------------------
6619 push (@modified_html, $prev_line);
6620 if ($prev_line ne $html_new_line)
6622 gp_message
("debugXL", $subr_name, "add_new_line_before = $add_new_line_before pushed $html_new_line");
6623 #------------------------------------------------------------------------------
6624 # There is no new-line yet, so add it.
6625 #------------------------------------------------------------------------------
6626 push (@modified_html, $html_new_line);
6630 #------------------------------------------------------------------------------
6631 # It was a new-line, so do nothing and continue.
6632 #------------------------------------------------------------------------------
6633 gp_message
("debugXL", $subr_name, "need to restore $html_new_line");
6637 #------------------------------------------------------------------------------
6638 # Add the newly created line.
6639 #------------------------------------------------------------------------------
6641 if ($hot_line eq "##")
6642 #------------------------------------------------------------------------------
6643 # Highlight the most expensive line.
6644 #------------------------------------------------------------------------------
6646 $modified_line = set_background_color_string
(
6648 $g_html_color_scheme{"background_color_hot"});
6650 #------------------------------------------------------------------------------
6651 # Sub-highlight the lines close enough to the hot line.
6652 #------------------------------------------------------------------------------
6655 my @current_metrics = split (" ", $metric_values);
6656 for my $metric (0 .. $#current_metrics)
6660 $current_value = $current_metrics[$metric];
6661 #------------------------------------------------------------------------------
6662 # As part of the padding process, non-breaking spaces may have been inserted
6663 # in an earlier phase. Temporarily remove these to make sure that the maximum
6664 # metric values can be computed.
6665 #------------------------------------------------------------------------------
6666 $current_value =~ s/ //g;
6667 if (exists ($max_metric_values[$metric]))
6669 $max_value = $max_metric_values[$metric];
6670 gp_message
("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
6671 if ( ($max_value > 0) and ($current_value > 0) and ($current_value != $max_value) )
6674 gp_message
("debugXL", $subr_name, "metric = $metric current_value = $current_value max_value = $max_value");
6675 my $relative_distance = 1.00 - abs ( ($max_value - $current_value)/$max_value );
6676 gp_message
("debugXL", $subr_name, "relative_distance = $relative_distance");
6677 if (($hp_value > 0) and ($relative_distance >= $hp_value/100.0))
6679 gp_message
("debugXL", $subr_name, "metric $metric is within the relative_distance");
6680 gp_message
("debugXL", $subr_name, "change bg modified_line = $modified_line");
6681 $modified_line = set_background_color_string
(
6683 $g_html_color_scheme{"background_color_lukewarm"});
6691 ## my @max_metric_values = ();
6692 push (@modified_html, $modified_line);
6693 if ($add_new_line_after)
6695 gp_message
("debugXL", $subr_name, "add_new_line_after = $add_new_line_after pushed $html_new_line");
6696 push (@modified_html, $html_new_line);
6702 my $msg = "parsing line $input_line";
6703 gp_message
("assertion", $subr_name, $msg);
6706 elsif ( $input_line =~ /$src_regex/ )
6708 if ( defined ($1) and defined ($2) )
6711 gp_message
("debugXL", $subr_name, "found a source code line: $input_line");
6712 gp_message
("debugXL", $subr_name, "\$1 = $1");
6713 gp_message
("debugXL", $subr_name, "\$2 = $2");
6714 gp_message
("debugXL", $subr_name, "\$3 = $3");
6719 #------------------------------------------------------------------------------
6720 # We need to replace the "<" symbol in the code by "<".
6721 #------------------------------------------------------------------------------
6722 $src_code =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
6724 my $target = "<a name='line_".$src_line."'>".$src_line.".</a>";
6725 gp_message
("debugXL", $subr_name, "src target = $target $src_code");
6727 my $modified_line = $blanks . $target . $src_code;
6728 gp_message
("debugXL", $subr_name, "modified_line = $modified_line");
6729 push (@modified_html, $modified_line);
6733 my $msg = "parsing line $input_line";
6734 gp_message
("assertion", $subr_name, $msg);
6737 elsif ( $input_line =~ /$function_regex/ )
6740 if (defined ($1) and defined ($2))
6742 $func_name_in_dis_file = $2;
6744 my $boldface = $TRUE;
6745 gp_message
("debugXL", $subr_name, "function_name = $2");
6746 my $function_line = "<Function: " . $func_name_in_dis_file . ">";
6750 if ($func_name_in_dis_file eq $target_function)
6752 my $color_function_name = color_string
(
6755 $g_html_color_scheme{"target_function_name"});
6756 my $label = "<a id=\"" . $g_function_tag_id{$target_function} . "\"></a>";
6757 $html_name = $label . $spaces . "<i>" . $color_function_name . "</i>";
6761 my $color_function_name = color_string
(
6764 $g_html_color_scheme{"non_target_function_name"});
6765 $html_name = "<i>" . $spaces . $color_function_name . "</i>";
6767 push (@modified_html, $html_name);
6771 my $msg = "parsing line $input_line";
6772 gp_message
("assertion", $subr_name, $msg);
6777 #------------------------------------------------------------------------------
6778 # Add an extra line with diagnostics.
6780 # TBD: The same is done in process_source but should be done only once.
6781 #------------------------------------------------------------------------------
6784 my $rounded_percentage = sprintf ("%.1f", $hp_value);
6785 $threshold_line = "<i>The setting for the highlight percentage";
6786 $threshold_line .= " (--highlight-percentage) option:";
6787 $threshold_line .= " " . $rounded_percentage . " (%)</i>";
6791 $threshold_line = "<i>The highlight percentage feature has not been";
6792 $threshold_line .= " enabled</i>";
6795 $html_home = ${ generate_home_link
("left") };
6796 $html_end = ${ terminate_html_document
() };
6798 push (@modified_html, "</pre>");
6799 push (@modified_html, $html_new_line);
6800 push (@modified_html, $threshold_line);
6801 push (@modified_html, $html_home);
6802 push (@modified_html, $html_new_line);
6803 push (@modified_html, $g_html_credits_line);
6804 push (@modified_html, $html_end);
6806 for my $i (0 .. $#modified_html)
6808 gp_message
("debugXL", $subr_name, "[$i] -> $modified_html[$i]");
6811 for my $i (0 .. $#modified_html)
6813 print HTML_OUTPUT
"$modified_html[$i]" . "\n";
6816 close (HTML_OUTPUT
);
6817 close (INPUT_DISASSEMBLY
);
6819 gp_message
("debug", $subr_name, "output is in file $html_dis_out");
6820 gp_message
("debug", $subr_name ,"completed processing disassembly");
6822 undef %branch_target;
6823 undef %extended_branch_target;
6824 undef %inverse_branch_target;
6826 return (\
@source_line, \
@metric);
6828 } #-- End of subroutine generate_dis_html
6830 #------------------------------------------------------------------------------
6831 # Generate all the function level information.
6832 #------------------------------------------------------------------------------
6833 sub generate_function_level_info
6835 my $subr_name = get_my_name
();
6837 my ($exp_dir_list_ref, $call_metrics, $summary_metrics, $input_string,
6838 $sort_fields_ref) = @_;
6840 my @exp_dir_list = @
{ $exp_dir_list_ref };
6841 my @sort_fields = @
{ $sort_fields_ref };
6845 my $gp_display_text_cmd;
6846 my $gp_functions_cmd;
6848 my $script_pc_metrics;
6850 my $outputdir = append_forward_slash
($input_string);
6852 my $script_file_PC = $outputdir."gp-script-PC";
6853 my $result_file = $outputdir."gp-out-PC.err";
6854 my $gp_error_file = $outputdir."gp-out-PC.err";
6855 my $func_limit = $g_user_settings{func_limit
}{current_value
};
6857 #------------------------------------------------------------------------------
6858 # The number of entries in the Function Overview includes <Total>, but that is
6859 # not a concern to the user and we add "1" to compensate for this.
6860 #------------------------------------------------------------------------------
6863 gp_message
("debug", $subr_name, "increased the local value for func_limit = $func_limit");
6865 $expr_name = join (" ", @exp_dir_list);
6867 gp_message
("debug", $subr_name, "expr_name = $expr_name");
6869 for my $i (0 .. $#sort_fields)
6871 gp_message
("debug", $subr_name, "sort_fields[$i] = $sort_fields[$i]");
6876 gp_message
("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function information files");
6878 open (SCRIPT_PC
, ">", $script_file_PC)
6879 or die ("$subr_name - unable to open script file $script_file_PC for writing: '$!'");
6880 gp_message
("debug", $subr_name, "opened file $script_file_PC for writing");
6882 #------------------------------------------------------------------------------
6883 # Get the list of functions.
6884 #------------------------------------------------------------------------------
6886 #------------------------------------------------------------------------------
6887 # Get the first metric.
6888 #------------------------------------------------------------------------------
6889 $summary_metrics =~ /^([^:]+)/;
6891 $g_first_metric = $1;
6892 $script_pc_metrics = "address:$summary_metrics";
6894 gp_message
("debugXL", $subr_name, "$func_limit");
6895 gp_message
("debugXL", $subr_name, "$summary_metrics");
6896 gp_message
("debugXL", $subr_name, "$first_metric");
6897 gp_message
("debugXL", $subr_name, "$script_pc_metrics");
6899 # Temporarily disabled print SCRIPT_PC "# limit $func_limit\n";
6900 # Temporarily disabled print SCRIPT_PC "limit $func_limit\n";
6901 print SCRIPT_PC
"# thread_select all\n";
6902 print SCRIPT_PC
"thread_select all\n";
6904 #------------------------------------------------------------------------------
6906 #------------------------------------------------------------------------------
6907 print SCRIPT_PC
"# outfile $outputdir"."header\n";
6908 print SCRIPT_PC
"outfile $outputdir"."header\n";
6910 #------------------------------------------------------------------------------
6911 # Else the output from the next line goes to last sort.func
6912 #------------------------------------------------------------------------------
6913 print SCRIPT_PC
"# outfile $outputdir"."gp-metrics-functions-PC\n";
6914 print SCRIPT_PC
"outfile $outputdir"."gp-metrics-functions-PC\n";
6915 print SCRIPT_PC
"# metrics $script_pc_metrics\n";
6916 print SCRIPT_PC
"metrics $script_pc_metrics\n";
6917 #------------------------------------------------------------------------------
6919 #------------------------------------------------------------------------------
6920 print SCRIPT_PC
"# outfile $outputdir"."functions.sort.func-PC\n";
6921 print SCRIPT_PC
"outfile $outputdir"."functions.sort.func-PC\n";
6922 print SCRIPT_PC
"# functions\n";
6923 print SCRIPT_PC
"functions\n";
6925 print SCRIPT_PC
"# outfile $outputdir"."functions.sort.func-PC2\n";
6926 print SCRIPT_PC
"outfile $outputdir"."functions.sort.func-PC2\n";
6927 print SCRIPT_PC
"# metrics address:name:$summary_metrics\n";
6928 print SCRIPT_PC
"metrics address:name:$summary_metrics\n";
6929 print SCRIPT_PC
"# sort $first_metric\n";
6930 print SCRIPT_PC
"sort $first_metric\n";
6931 print SCRIPT_PC
"# functions\n";
6932 print SCRIPT_PC
"functions\n";
6933 #------------------------------------------------------------------------------
6934 # Go through all the possible metrics and sort by each of them.
6935 #------------------------------------------------------------------------------
6936 for my $field (@sort_fields)
6938 gp_message
("debug", $subr_name, "sort_fields field = $field");
6939 #------------------------------------------------------------------------------
6940 # Else the output from the next line goes to last sort.func
6941 #------------------------------------------------------------------------------
6942 print SCRIPT_PC
"# outfile $outputdir"."gp-metrics-".$field."-PC\n";
6943 print SCRIPT_PC
"outfile $outputdir"."gp-metrics-".$field."-PC\n";
6944 print SCRIPT_PC
"# metrics $script_pc_metrics\n";
6945 print SCRIPT_PC
"metrics $script_pc_metrics\n";
6946 print SCRIPT_PC
"# outfile $outputdir".$field.".sort.func-PC\n";
6947 print SCRIPT_PC
"outfile $outputdir".$field.".sort.func-PC\n";
6948 print SCRIPT_PC
"# sort $field\n";
6949 print SCRIPT_PC
"sort $field\n";
6950 print SCRIPT_PC
"# functions\n";
6951 print SCRIPT_PC
"functions\n";
6953 print SCRIPT_PC
"# metrics address:name:$summary_metrics\n";
6954 print SCRIPT_PC
"metrics address:name:$summary_metrics\n";
6955 print SCRIPT_PC
"# outfile $outputdir".$field.".sort.func-PC2\n";
6956 print SCRIPT_PC
"outfile $outputdir".$field.".sort.func-PC2\n";
6957 print SCRIPT_PC
"# sort $field\n";
6958 print SCRIPT_PC
"sort $field\n";
6959 print SCRIPT_PC
"# functions\n";
6960 print SCRIPT_PC
"functions\n";
6963 #------------------------------------------------------------------------------
6964 # Get caller-callee list
6965 #------------------------------------------------------------------------------
6966 print SCRIPT_PC
"# outfile " . $outputdir."caller-callee-PC2\n";
6967 print SCRIPT_PC
"outfile " . $outputdir."caller-callee-PC2\n";
6968 print SCRIPT_PC
"# metrics address:name:$summary_metrics\n";
6969 print SCRIPT_PC
"metrics address:name:$summary_metrics\n";
6970 print SCRIPT_PC
"# callers-callees\n";
6971 print SCRIPT_PC
"callers-callees\n";
6972 #------------------------------------------------------------------------------
6973 # Else the output from the next line goes to last sort.func
6974 #------------------------------------------------------------------------------
6975 print SCRIPT_PC
"# outfile $outputdir"."gp-metrics-calls-PC\n";
6976 print SCRIPT_PC
"outfile $outputdir"."gp-metrics-calls-PC\n";
6977 $script_pc_metrics = "address:$call_metrics";
6978 print SCRIPT_PC
"# metrics $script_pc_metrics\n";
6979 print SCRIPT_PC
"metrics $script_pc_metrics\n";
6981 #------------------------------------------------------------------------------
6983 #------------------------------------------------------------------------------
6984 print SCRIPT_PC
"# outfile $outputdir"."calls.sort.func-PC\n";
6985 print SCRIPT_PC
"outfile $outputdir"."calls.sort.func-PC\n";
6987 #------------------------------------------------------------------------------
6988 # Get caller-callee list
6989 #------------------------------------------------------------------------------
6990 print SCRIPT_PC
"# callers-callees\n";
6991 print SCRIPT_PC
"callers-callees\n";
6993 #------------------------------------------------------------------------------
6994 # Else the output from the next line goes to last sort.func
6995 #------------------------------------------------------------------------------
6996 print SCRIPT_PC
"# outfile $outputdir"."gp-metrics-calltree-PC\n";
6997 print SCRIPT_PC
"outfile $outputdir"."gp-metrics-calltree-PC\n";
6998 print SCRIPT_PC
"# metrics $script_pc_metrics\n";
6999 print SCRIPT_PC
"metrics $script_pc_metrics\n";
7001 if ($g_user_settings{"calltree"}{"current_value"} eq "on")
7003 gp_message
("verbose", $subr_name, "Generate the file with the calltree information");
7004 #------------------------------------------------------------------------------
7006 #------------------------------------------------------------------------------
7007 print SCRIPT_PC
"# outfile $outputdir"."calltree.sort.func-PC\n";
7008 print SCRIPT_PC
"outfile $outputdir"."calltree.sort.func-PC\n";
7009 print SCRIPT_PC
"# calltree\n";
7010 print SCRIPT_PC
"calltree\n";
7013 #------------------------------------------------------------------------------
7014 # Get the default set of metrics
7015 #------------------------------------------------------------------------------
7016 my $full_metrics_ref;
7018 my $full_function_view = $outputdir . "functions.full";
7020 $full_metrics_ref = get_all_the_metrics
(\
$expr_name, \
$outputdir);
7022 $all_metrics = "address:name:";
7023 $all_metrics .= ${$full_metrics_ref};
7024 gp_message
("debug", $subr_name, "all_metrics = $all_metrics");
7025 #------------------------------------------------------------------------------
7026 # Get the name, address, and full overview of all metrics for all functions
7027 #------------------------------------------------------------------------------
7028 print SCRIPT_PC
"# limit 0\n";
7029 print SCRIPT_PC
"limit 0\n";
7030 print SCRIPT_PC
"# metrics $all_metrics\n";
7031 print SCRIPT_PC
"metrics $all_metrics\n";
7032 print SCRIPT_PC
"# thread_select all\n";
7033 print SCRIPT_PC
"thread_select all\n";
7034 print SCRIPT_PC
"# sort default\n";
7035 print SCRIPT_PC
"sort default\n";
7036 print SCRIPT_PC
"# outfile $full_function_view\n";
7037 print SCRIPT_PC
"outfile $full_function_view\n";
7038 print SCRIPT_PC
"# functions\n";
7039 print SCRIPT_PC
"functions\n";
7043 $result_file = $outputdir."gp-out-PC.err";
7044 $gp_error_file = $outputdir.$g_gp_error_logfile;
7046 $gp_functions_cmd = "$GP_DISPLAY_TEXT -limit $func_limit ";
7047 $gp_functions_cmd .= "-viewmode machine -compare off ";
7048 $gp_functions_cmd .= "-script $script_file_PC $expr_name";
7050 gp_message
("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get function level information");
7052 $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file";
7054 gp_message
("debugXL", $subr_name,"cmd = $gp_display_text_cmd");
7056 my ($error_code, $cmd_output) = execute_system_cmd
($gp_display_text_cmd);
7058 if ($error_code != 0)
7060 $ignore_value = msg_display_text_failure
($gp_display_text_cmd,
7063 gp_message
("abort", $subr_name, "execution terminated");
7066 #------------------------------------------------------------------------------
7067 # Parse the full function view and store the data.
7068 #------------------------------------------------------------------------------
7069 my @input_data = ();
7070 my $empty_line_regex = '^\s*$';
7072 ## my $full_function_view = $outputdir . "functions.full";
7074 open (ALL_FUNC_DATA
, "<", $full_function_view)
7075 or die ("$subr_name - unable to open output file $full_function_view for reading '$!'");
7076 gp_message
("debug", $subr_name, "opened file $full_function_view for reading");
7078 chomp (@input_data = <ALL_FUNC_DATA
>);
7080 my $start_scanning = $FALSE;
7081 for (my $line = 0; $line <= $#input_data; $line++)
7083 my $input_line = $input_data[$line];
7085 # if ($input_line =~ /^<Total>\s+.*/)
7086 if ($input_line =~ /\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)/)
7088 $start_scanning = $TRUE;
7090 elsif ($input_line =~ /$empty_line_regex/)
7092 $start_scanning = $FALSE;
7095 if ($start_scanning)
7097 gp_message
("debugXL", $subr_name, "$line: $input_data[$line]");
7099 push (@g_full_function_view_table, $input_data[$line]);
7102 my $full_hex_address = $1;
7104 my $all_metrics = $3;
7105 if ($full_hex_address =~ /(\d+):0x(\S+)/)
7107 $hex_address = "0x" . $2;
7109 $g_function_view_all{$routine}{"hex_address"} = $hex_address;
7110 $g_function_view_all{$routine}{"all_metrics"} = $all_metrics;
7114 for my $i (keys %g_function_view_all)
7116 gp_message
("debugXL", $subr_name, "key = $i $g_function_view_all{$i}{'hex_address'} $g_function_view_all{$i}{'all_metrics'}");
7119 for my $i (keys @g_full_function_view_table)
7121 gp_message
("debugXL", $subr_name, "g_full_function_view_table[$i] = $i $g_full_function_view_table[$i]");
7124 return ($script_pc_metrics);
7126 } #-- End of subroutine generate_function_level_info
7128 #------------------------------------------------------------------------------
7129 # Generate all the files needed for the function view.
7130 #------------------------------------------------------------------------------
7131 sub generate_function_view
7133 my $subr_name = get_my_name
();
7135 my ($directory_name_ref, $summary_metrics_ref, $number_of_metrics_ref,
7136 $function_info_ref, $function_view_structure_ref, $function_address_info_ref,
7137 $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref) = @_;
7139 my $directory_name = ${ $directory_name_ref };
7140 my @function_info = @
{ $function_info_ref };
7141 my %function_view_structure = %{ $function_view_structure_ref };
7142 my $summary_metrics = ${ $summary_metrics_ref };
7143 my $number_of_metrics = ${ $number_of_metrics_ref };
7144 my %function_address_info = %{ $function_address_info_ref };
7145 my @sort_fields = @
{ $sort_fields_ref };
7146 my @exp_dir_list = @
{ $exp_dir_list_ref };
7147 my %addressobjtextm = %{ $addressobjtextm_ref };
7149 my @abs_path_exp_dirs = ();
7150 my @experiment_directories;
7152 my $target_function;
7156 my %html_source_functions = ();
7160 my $input_experiments;
7168 my $new_target_function;
7170 my $html_output_file;
7171 my $html_function_view;
7179 my $full_index_line;
7180 my $acknowledgement;
7181 my @full_function_view_line = ();
7185 my $html_first_metric_file;
7186 my $html_new_line = "<br>";
7187 my $html_acknowledgement;
7191 my $html_title_header;
7193 my $outputdir = append_forward_slash
($directory_name);
7194 my $LANG = $g_locale_settings{"LANG"};
7195 my $decimal_separator = $g_locale_settings{"decimal_separator"};
7197 $input_experiments = join (", ", @exp_dir_list);
7199 for my $i (0 .. $#exp_dir_list)
7201 my $dir = get_basename
($exp_dir_list[$i]);
7202 push @abs_path_exp_dirs, $dir;
7204 $input_experiments = join (", ", @abs_path_exp_dirs);
7206 gp_message
("debug", $subr_name, "input_experiments = $input_experiments");
7208 #------------------------------------------------------------------------------
7209 # TBD: This should be done only once and much earlier.
7210 #------------------------------------------------------------------------------
7211 @experiment_directories = split (",", $input_experiments);
7213 #------------------------------------------------------------------------------
7214 # For every function in the function overview, set up an html structure with
7215 # the various hyperlinks.
7216 #------------------------------------------------------------------------------
7218 #------------------------------------------------------------------------------
7219 # Core loop that generates an HTML line for each function.
7220 #------------------------------------------------------------------------------
7221 my $top_of_table = $FALSE;
7222 for my $i (0 .. $#function_info)
7224 if (defined ($function_info[$i]{"alt_name"}))
7226 $target_function = $function_info[$i]{"alt_name"};
7230 my $msg = "function_info[$i]{\"alt_name\"} is not defined";
7231 gp_message
("assertion", $subr_name, $msg);
7234 $html_source_functions{$target_function} = $function_info[$i]{"html function block"};
7237 for my $i (sort keys %html_source_functions)
7239 gp_message
("debugXL", $subr_name, "html_source_functions{$i} = $html_source_functions{$i}");
7242 $file_title = "Function view for experiments " . $input_experiments;
7244 #------------------------------------------------------------------------------
7245 # Example input file:
7247 # Current metrics: address:name:e.totalcpu:e.cycles:e+insts:e+llm
7248 # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
7249 # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
7250 # Functions sorted by metric: Exclusive Total CPU Time
7252 # PC Addr. Name Excl. Excl. CPU Excl. Excl.
7253 # Total Cycles Instructions Last-Level
7254 # CPU sec. sec. Executed Cache Misses
7255 # 1:0x00000000 <Total> 3.502 4.005 15396819700 24024250
7256 # 2:0x000021ae mxv_core 3.342 3.865 14500538981 23824045
7257 # 6:0x0003af50 erand48_r 0.080 0.084 768240570 0
7258 # 2:0x00001f7b init_data 0.040 0.028 64020043 200205
7259 # 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
7261 #------------------------------------------------------------------------------
7263 for my $metric (@sort_fields)
7265 $overview_file = $outputdir . $metric . ".sort.func-PC2";
7267 $exp_type = $metric;
7269 if ($metric eq "functions")
7271 $html_function_view .= $g_html_base_file_name{"function_view"} . ".html";
7275 $html_function_view = $g_html_base_file_name{"function_view"} . "." . $metric . ".html";
7277 #------------------------------------------------------------------------------
7278 # The default function view is based upon the first metric in the list. We use
7279 # this file in the index.html file.
7280 #------------------------------------------------------------------------------
7281 if ($metric eq $g_first_metric)
7283 $html_first_metric_file = $html_function_view;
7284 my $txt = "g_first_metric = $g_first_metric ";
7285 $txt .= "html_first_metric_file = $html_first_metric_file";
7286 gp_message
("debugXL", $subr_name, $txt);
7289 $html_output_file = $outputdir . $html_function_view;
7291 open (FUNCTION_VIEW
, ">", $html_output_file)
7292 or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
7293 gp_message
("debug", $subr_name, "opened file $html_output_file for writing");
7295 $html_home = ${ generate_home_link
("right") };
7296 $html_header = ${ create_html_header
(\
$file_title) };
7298 $page_title = "Function View";
7300 $position_text = "center";
7301 $html_title_header = ${ generate_a_header
(\
$page_title, \
$size_text, \
$position_text) };
7303 print FUNCTION_VIEW
$html_header;
7304 print FUNCTION_VIEW
$html_home;
7305 print FUNCTION_VIEW
$html_title_header;
7306 print FUNCTION_VIEW
"$_" for @g_html_experiment_stats;
7307 print FUNCTION_VIEW
$html_new_line . "\n";
7309 my $function_view_structure_ref = process_function_overview
(
7313 \
$number_of_metrics,
7315 \
%function_view_structure,
7318 my %function_view_structure = %{ $function_view_structure_ref };
7320 #------------------------------------------------------------------------------
7321 # Core part: extract the true function name and find the html code for it.
7322 #------------------------------------------------------------------------------
7323 gp_message
("debugXL", $subr_name, "the final table");
7325 print FUNCTION_VIEW
"<pre>\n";
7326 print FUNCTION_VIEW
"$_\n" for @
{ $function_view_structure{"header"} };
7328 my $max_length_header = $function_view_structure{"max header length"};
7329 my $max_length_metrics = $function_view_structure{"max metrics length"};
7331 #------------------------------------------------------------------------------
7332 # Add 4 more spaces for the distance to the function names. Purely cosmetic.
7333 #------------------------------------------------------------------------------
7334 my $pad = max
($max_length_metrics, $max_length_header) + 4;
7336 for my $i (1 .. $pad)
7338 $spaces .= " ";
7341 #------------------------------------------------------------------------------
7342 # Add extra space for the /blank/*/ marker!
7343 #------------------------------------------------------------------------------
7344 $spaces .= " ";
7345 my $func_header = $spaces . $function_view_structure{"table name"};
7346 gp_message
("debugXL", $subr_name, "func_header = " . $func_header);
7348 print FUNCTION_VIEW
$spaces . "<b>" .
7349 $function_view_structure{"table name"} .
7350 "</b>" . $html_new_line . "\n";
7352 #------------------------------------------------------------------------------
7353 # If the header is longer than the metrics, add spaces to padd the difference.
7354 # Also add the same 4 spaces between the metric values and the function name.
7355 #------------------------------------------------------------------------------
7357 if ($max_length_header > $max_length_metrics)
7359 $pad = $max_length_header - $max_length_metrics;
7363 for my $i (1 .. $pad)
7365 $spaces .= " ";
7368 #------------------------------------------------------------------------------
7369 # This is where it literally all comes together. The metrics and function
7370 # parts are combined.
7371 #------------------------------------------------------------------------------
7372 ## for my $i (keys @{ $function_view_structure{"function table"} })
7373 for my $i (0 .. $#{ $function_view_structure{"function table"} })
7375 my $p1 = $function_view_structure{"metrics part"}[$i];
7376 my $p2 = $function_view_structure{"function table"}[$i];
7378 $full_index_line = $p1 . $spaces . $p2;
7380 push (@full_function_view_line, $full_index_line);
7383 print FUNCTION_VIEW
"$_\n" for @full_function_view_line;
7385 #------------------------------------------------------------------------------
7386 # Clear the array before filling it up again.
7387 #------------------------------------------------------------------------------
7388 @full_function_view_line = ();
7390 #------------------------------------------------------------------------------
7391 # Get the acknowledgement, return to main link, and final html statements.
7392 #------------------------------------------------------------------------------
7393 $html_home = ${ generate_home_link
("left") };
7394 $html_acknowledgement = ${ create_html_credits
() };
7395 $html_end = ${ terminate_html_document
() };
7397 print FUNCTION_VIEW
"</pre>\n";
7398 print FUNCTION_VIEW
$html_home;
7399 print FUNCTION_VIEW
$html_new_line . "\n";
7400 print FUNCTION_VIEW
$html_acknowledgement;
7401 print FUNCTION_VIEW
$html_end;
7403 close (FUNCTION_VIEW
);
7406 return (\
$html_first_metric_file);
7408 } #-- End of subroutine generate_function_view
7410 #------------------------------------------------------------------------------
7411 # Generate an html line that links back to index.html. The text can either
7412 # be positioned to the left or to the right.
7413 #------------------------------------------------------------------------------
7414 sub generate_home_link
7416 my $subr_name = get_my_name
();
7418 my ($which_side) = @_;
7422 if (($which_side ne "left") and ($which_side ne "right"))
7424 my $msg = "which_side = $which_side not supported";
7425 gp_message
("assertion", $subr_name, $msg);
7428 $html_home_line .= "<div class=\"" . $which_side . "\">";
7429 $html_home_line .= "<br><a href='" . $g_html_base_file_name{"index"};
7430 $html_home_line .= ".html' style='background-color:";
7431 $html_home_line .= $g_html_color_scheme{"index"};
7432 $html_home_line .= "'><b>Return to main view</b></a>";
7433 $html_home_line .= "</div>";
7435 return (\
$html_home_line);
7437 } #-- End of subroutine generate_home_link
7439 #------------------------------------------------------------------------------
7440 # Generate a block of html for this function block.
7441 #------------------------------------------------------------------------------
7442 sub generate_html_function_blocks
7444 my $subr_name = get_my_name
();
7451 $length_first_metric_ref,
7452 $special_marker_ref,
7453 $the_function_name_ref,
7455 $number_of_metrics_ref,
7456 $data_function_block_ref,
7458 $function_view_structure_ref) = @_;
7460 my $index_start = ${ $index_start_ref };
7461 my $index_end = ${ $index_end_ref };
7462 my @hex_addresses = @
{ $hex_addresses_ref };
7463 my @the_metrics = @
{ $the_metrics_ref };
7464 my @length_first_metric = @
{ $length_first_metric_ref };
7465 my @special_marker = @
{ $special_marker_ref };
7466 my @the_function_name = @
{ $the_function_name_ref};
7468 my $separator = ${ $separator_ref };
7469 my $number_of_metrics = ${ $number_of_metrics_ref };
7470 my $data_function_block = ${ $data_function_block_ref };
7471 my @function_info = @
{ $function_info_ref };
7472 my %function_view_structure = %{ $function_view_structure_ref };
7474 my $decimal_separator = $g_locale_settings{"decimal_separator"};
7476 my @html_block_prologue = ();
7477 my @html_code_function_block = ();
7478 my @function_lines = ();
7480 my @address_field = ();
7481 my @metric_values = ();
7482 my @function_names = ();
7483 my @final_function_names = ();
7485 my @split_number = ();
7486 my @function_tags = ();
7489 my $current_function_name;
7492 my $full_hex_address;
7494 my $target_function;
7495 my $marker_function;
7499 my $max_metrics_length = 0;
7503 my $current_address;
7507 my $length_first_field;
7516 my $create_hyperlinks;
7518 state $first_call = $TRUE;
7519 state $reference_length;
7521 #------------------------------------------------------------------------------
7522 # If the length of the first metric is less than the maximum over all first
7523 # metrics, add spaces to the left to ensure correct alignment.
7524 #------------------------------------------------------------------------------
7525 for my $k ($index_start .. $index_end)
7527 my $pad = $g_max_length_first_metric - $length_first_metric[$k];
7531 for my $s (1 .. $pad)
7533 $spaces .= " ";
7535 $the_metrics[$k] = $spaces . $the_metrics[$k];
7537 my $msg = "padding spaces = $spaces the_metrics[$k] = $the_metrics[$k]";
7538 gp_message
("debugXL", $subr_name, $msg);
7541 ## my $end_game = "end game3=> pad = $pad" . $hex_addresses[$k] . " " . $the_metrics[$k] . " " . $special_marker[$k] . $the_function_name[$k];
7542 ## gp_message ("debugXL", $subr_name, $end_game);
7545 #------------------------------------------------------------------------------
7546 # An example what @function_lines should look like after the split:
7548 # 6:0x0003ad20 drand48 0.100 0.084 768240570 0
7549 # 6:0x0003af50 *erand48_r 0.080 0.084 768240570 0
7550 # 6:0x0003b160 __drand48_iterate 0.020 0. 0 0
7551 #------------------------------------------------------------------------------
7552 @function_lines = split ($separator, $data_function_block);
7554 #------------------------------------------------------------------------------
7555 # Parse the individual lines. Replace multi-occurrence functions by their
7556 # unique alternative name and mark the target function.
7558 # The above split operation produces an empty first field because the line
7559 # starts with the separator. This is why skip the first field.
7560 #------------------------------------------------------------------------------
7561 for my $i ($index_start .. $index_end)
7563 my $input_line = $the_metrics[$i];
7565 gp_message
("debugXL", $subr_name, "the_metrics[$i] = ". $the_metrics[$i]);
7567 #------------------------------------------------------------------------------
7568 # In case the last metric is 0. only, we append 3 extra characters that
7569 # represent zero. We cannot change the number to 0.000 though because that
7570 # has a different interpretation than 0.
7571 # In a later phase, the "ZZZ" symbol will be removed again, but for now it
7572 # creates consistency in, for example, the length of the metrics part.
7573 #------------------------------------------------------------------------------
7574 if ($input_line =~ /[\w0-9$decimal_separator]*(0$decimal_separator$)/)
7578 my $decimal_point = $decimal_separator;
7579 $decimal_point =~ s/\\//;
7580 my $txt = "input_line = $input_line = ended with 0";
7581 $txt .= $decimal_point;
7582 gp_message
("debugXL", $subr_name, $txt);
7584 $the_metrics[$i] .= "ZZZ";
7588 $hex_address = $hex_addresses[$i];
7589 $marker_function = $special_marker[$i];
7590 $routine = $the_function_name[$i];
7591 #------------------------------------------------------------------------------
7592 # Get the length of the metrics line before ZZZ is replaced by spaces.
7593 #------------------------------------------------------------------------------
7594 $all_metrics = $the_metrics[$i];
7595 $metrics_length = length ($all_metrics);
7596 $all_metrics =~ s/ZZZ/ /g;
7598 $max_metrics_length = max
($max_metrics_length, $metrics_length);
7600 push (@marker, $marker_function);
7601 push (@address_field, $hex_address);
7602 push (@metric_values, $all_metrics);
7603 push (@function_names, $routine);
7605 my $index_into_function_info_ref = get_index_function_info
(
7607 \
$hex_addresses[$i],
7608 $function_info_ref);
7610 my $index_into_function_info = ${ $index_into_function_info_ref };
7611 $target_tag = $function_info[$index_into_function_info]{"tag_id"};
7612 $alt_name = $function_info[$index_into_function_info]{"alt_name"};
7614 #------------------------------------------------------------------------------
7615 # Keep the name of the target function (the one marked with a *) for later use.
7616 # This is the tag that identifies the block in the caller-callee output. The
7617 # tag is used in the link to the caller-callee in the function overview.
7618 #------------------------------------------------------------------------------
7619 if ($marker_function eq "*")
7621 $tag_for_header = $target_tag;
7622 $name_in_header = $alt_name;
7624 #------------------------------------------------------------------------------
7625 # We need to replace the "<" symbol in the code by "<".
7626 #------------------------------------------------------------------------------
7627 $name_in_header =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
7630 push (@final_function_names, $alt_name);
7631 push (@function_tags, $target_tag);
7633 gp_message
("debugXL", $subr_name, "index_into_function_info = $index_into_function_info");
7634 gp_message
("debugXL", $subr_name, "target_tag = $target_tag");
7635 gp_message
("debugXL", $subr_name, "alt_name = $alt_name");
7637 } #-- End of loop for my $i ($index_start .. $index_end)
7639 my $tag_line = "<a id='" . $tag_for_header . "'></a>";
7640 $html_line = "<br>\n";
7641 $html_line .= $tag_line . "Function name: ";
7642 $html_line .= "<span style='color:" . $g_html_color_scheme{"target_function_name"} . "'>";
7643 $html_line .= "<b>" . $name_in_header . "</b></span>\n";
7644 $html_line .= "<br>";
7646 push (@html_block_prologue, $html_line);
7648 gp_message
("debugXL", $subr_name, "the final function block for $name_in_header");
7650 $href_file = $g_html_base_file_name{"caller_callee"} . ".html";
7652 #------------------------------------------------------------------------------
7653 # Process the function blocks and generate the HTML structure for them.
7654 #------------------------------------------------------------------------------
7655 for my $i (0 .. $#final_function_names)
7657 $current_function_name = $final_function_names[$i];
7658 gp_message
("debugXL", $subr_name, "current_function_name = $current_function_name");
7660 #------------------------------------------------------------------------------
7661 # Do not add hyperlinks for <Total>.
7662 #------------------------------------------------------------------------------
7663 if ($current_function_name eq "<Total>")
7665 $create_hyperlinks = $FALSE;
7669 $create_hyperlinks = $TRUE;
7672 #------------------------------------------------------------------------------
7673 # We need to replace the "<" symbol in the code by "<".
7674 #------------------------------------------------------------------------------
7675 $current_function_name =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
7677 $html_line = $metric_values[$i] . " ";
7679 if ($marker[$i] eq "*")
7681 $current_function_name = "<b>" . $current_function_name . "</b>";
7683 $html_line .= " <a href='" . $href_file . "#" . $function_tags[$i] . "'>" . $current_function_name . "</a>";
7685 if ($marker[$i] eq "*")
7687 $html_line = "<br>" . $html_line;
7689 elsif (($marker[$i] ne "*") and ($i == 0))
7691 $html_line = "<br>" . $html_line;
7694 gp_message
("debugXL", $subr_name, "html_line = $html_line");
7696 #------------------------------------------------------------------------------
7697 # Find the index into "function_info" for this particular function.
7698 #------------------------------------------------------------------------------
7699 $routine = $function_names[$i];
7700 $current_address = $address_field[$i];
7702 my $target_index_ref = find_index_in_function_info
(\
$routine, \
$current_address, \
@function_info);
7703 my $target_index = ${ $target_index_ref };
7705 gp_message
("debugXL", $subr_name, "routine = $routine current_address = $current_address target_index = $target_index");
7707 #------------------------------------------------------------------------------
7708 # TBD Do this once for each function and store the result. This is a saving
7709 # because functions may and typically will appear more than once.
7710 #------------------------------------------------------------------------------
7711 my $spaces_left = $function_view_structure{"max function length"} - $function_info[$target_index]{"function length"};
7713 #------------------------------------------------------------------------------
7714 # Add the links to the line. Make sure there is at least one space.
7715 #------------------------------------------------------------------------------
7716 my $spaces = " ";
7717 for my $k (1 .. $spaces_left)
7719 $spaces .= " ";
7722 if ($create_hyperlinks)
7724 $html_line .= $spaces;
7725 $html_line .= $function_info[$target_index]{"href_source"};
7726 $html_line .= " ";
7727 $html_line .= $function_info[$target_index]{"href_disassembly"};
7730 push (@html_code_function_block, $html_line);
7733 for my $lines (0 .. $#html_code_function_block)
7735 gp_message
("debugXL", $subr_name, "final html block = " . $html_code_function_block[$lines]);
7738 return (\
@html_block_prologue, \
@html_code_function_block);
7740 } #-- End of subroutine generate_html_function_blocks
7742 #------------------------------------------------------------------------------
7743 # Get all the metrics available
7745 # (gp-display-text) metric_list
7746 # Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name
7747 # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
7748 # Available metrics:
7749 # Exclusive Total CPU Time: e.%totalcpu
7750 # Inclusive Total CPU Time: i.%totalcpu
7751 # Exclusive CPU Cycles: e.+%cycles
7752 # Inclusive CPU Cycles: i.+%cycles
7753 # Exclusive Instructions Executed: e+%insts
7754 # Inclusive Instructions Executed: i+%insts
7755 # Exclusive Last-Level Cache Misses: e+%llm
7756 # Inclusive Last-Level Cache Misses: i+%llm
7757 # Exclusive Instructions Per Cycle: e+IPC
7758 # Inclusive Instructions Per Cycle: i+IPC
7759 # Exclusive Cycles Per Instruction: e+CPI
7760 # Inclusive Cycles Per Instruction: i+CPI
7762 # PC Address: address
7764 #------------------------------------------------------------------------------
7765 sub get_all_the_metrics
7767 my $subr_name = get_my_name
();
7769 my ($experiments_ref, $outputdir_ref) = @_;
7771 my $experiments = ${ $experiments_ref };
7772 my $outputdir = ${ $outputdir_ref };
7775 my $gp_functions_cmd;
7776 my $gp_display_text_cmd;
7778 my $metrics_output_file = $outputdir . "metrics-all";
7779 my $result_file = $outputdir . $g_gp_output_file;
7780 my $gp_error_file = $outputdir . $g_gp_error_logfile;
7781 my $script_file_metrics = $outputdir . "script-metrics";
7783 my @metrics_data = ();
7785 open (SCRIPT_METRICS
, ">", $script_file_metrics)
7786 or die ("$subr_name - unable to open script file $script_file_metrics for writing: '$!'");
7787 gp_message
("debug", $subr_name, "opened script file $script_file_metrics for writing");
7789 print SCRIPT_METRICS
"# outfile $metrics_output_file\n";
7790 print SCRIPT_METRICS
"outfile $metrics_output_file\n";
7791 print SCRIPT_METRICS
"# metric_list\n";
7792 print SCRIPT_METRICS
"metric_list\n";
7794 close (SCRIPT_METRICS
);
7796 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file_metrics $experiments";
7798 gp_message
("debug", $subr_name, "calling $GP_DISPLAY_TEXT to get all the metrics");
7800 $gp_display_text_cmd = "$gp_functions_cmd 1>> $result_file 2>> $gp_error_file";
7801 gp_message
("debug", $subr_name, "cmd = $gp_display_text_cmd");
7803 my ($error_code, $cmd_output) = execute_system_cmd
($gp_display_text_cmd);
7805 if ($error_code != 0)
7807 $ignore_value = msg_display_text_failure
($gp_display_text_cmd,
7810 gp_message
("abort", $subr_name, "execution terminated");
7813 open (METRICS_INFO
, "<", $metrics_output_file)
7814 or die ("$subr_name - unable to open file $metrics_output_file for reading '$!'");
7815 gp_message
("debug", $subr_name, "opened file $metrics_output_file for reading");
7817 #------------------------------------------------------------------------------
7818 # Read the input file into memory.
7819 #------------------------------------------------------------------------------
7820 chomp (@metrics_data = <METRICS_INFO
>);
7821 gp_message
("debug", $subr_name, "read all contents of file $metrics_output_file into memory");
7822 gp_message
("debug", $subr_name, "\$#metrics_data = $#metrics_data");
7825 my $ignore_lines_regex = '^(?:Current|Available|\s+Size:|\s+PC Address:|\s+Name:)';
7826 my $split_line_regex = '(.*): (.*)';
7827 my $empty_line_regex = '^\s*$';
7828 my @metric_list_all = ();
7829 for (my $line_no=0; $line_no <= $#metrics_data; $line_no++)
7832 $input_line = $metrics_data[$line_no];
7834 ## if ( not (($input_line =~ /$ignore_lines_regex/ or ($input_line =~ /^\s*$/))))
7835 if ( not ($input_line =~ /$ignore_lines_regex/) and not ($input_line =~ /$empty_line_regex/) )
7837 if ($input_line =~ /$split_line_regex/)
7839 #------------------------------------------------------------------------------
7840 # Remove the percentages.
7841 #------------------------------------------------------------------------------
7842 my $metric_definition = $2;
7843 $metric_definition =~ s/\%//g;
7844 gp_message
("debug", $subr_name, "line_no = $line_no $metrics_data[$line_no] metric_definition = $metric_definition");
7845 push (@metric_list_all, $metric_definition);
7851 gp_message
("debug", $subr_name, "\@metric_list_all = @metric_list_all");
7853 my $final_list = join (":", @metric_list_all);
7854 gp_message
("debug", $subr_name, "final_list = $final_list");
7856 close (METRICS_INFO
);
7858 return (\
$final_list);
7860 } #-- End of subroutine get_all_the_metrics
7862 #------------------------------------------------------------------------------
7863 # A simple function to return the basename using fileparse. To keep things
7864 # simple, a suffixlist is not supported. In case this is needed, use the
7865 # fileparse function directly.
7866 #------------------------------------------------------------------------------
7869 my ($full_name) = @_;
7875 ($basename_value, $ignore_value_1, $ignore_value_2) = fileparse
($full_name);
7877 return ($basename_value);
7879 } #-- End of subroutine get_basename
7881 #------------------------------------------------------------------------------
7882 # Get the details on the experiments and store these in a file. Each
7883 # experiment has its own file. This makes the processing easier.
7884 #------------------------------------------------------------------------------
7885 sub get_experiment_info
7887 my $subr_name = get_my_name
();
7889 my ($outputdir_ref, $exp_dir_list_ref) = @_;
7891 my $outputdir = ${ $outputdir_ref };
7892 my @exp_dir_list = @
{ $exp_dir_list_ref };
7899 my @experiment_data = ();
7901 my $gp_display_text_cmd;
7902 my $gp_functions_cmd;
7909 my $the_experiments;
7911 $the_experiments = join (" ", @exp_dir_list);
7913 $script_file = $outputdir . "gp-info-exp.script";
7914 $exp_info_file = $outputdir . "gp-info-exp-list.out";
7915 $overview_file = $outputdir . "gp-overview.out";
7916 $gp_log_file = $outputdir . $g_gp_output_file;
7917 $gp_error_file = $outputdir . $g_gp_error_logfile;
7919 open (SCRIPT_EXPERIMENT_INFO
, ">", $script_file)
7920 or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
7921 gp_message
("debug", $subr_name, "opened script file $script_file for writing");
7923 #------------------------------------------------------------------------------
7924 # Attributed User CPU Time=a.user : for calltree - see P37 in manual
7925 #------------------------------------------------------------------------------
7926 print SCRIPT_EXPERIMENT_INFO
"# compare on\n";
7927 print SCRIPT_EXPERIMENT_INFO
"compare on\n";
7928 print SCRIPT_EXPERIMENT_INFO
"# outfile $exp_info_file\n";
7929 print SCRIPT_EXPERIMENT_INFO
"outfile $exp_info_file\n";
7930 print SCRIPT_EXPERIMENT_INFO
"# exp_list\n";
7931 print SCRIPT_EXPERIMENT_INFO
"exp_list\n";
7932 print SCRIPT_EXPERIMENT_INFO
"# outfile $overview_file\n";
7933 print SCRIPT_EXPERIMENT_INFO
"outfile $overview_file\n";
7934 print SCRIPT_EXPERIMENT_INFO
"# overview\n";
7935 print SCRIPT_EXPERIMENT_INFO
"overview\n";
7937 close SCRIPT_EXPERIMENT_INFO
;
7939 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments";
7941 gp_message
("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the experiment information");
7943 $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file";
7945 ($error_code, $cmd_output) = execute_system_cmd
($gp_display_text_cmd);
7947 if ($error_code != 0)
7949 $ignore_value = msg_display_text_failure
($gp_display_text_cmd,
7952 gp_message
("abort", $subr_name, "execution terminated");
7955 #------------------------------------------------------------------------------
7956 # The first file has the following format:
7958 # ID Sel PID Experiment
7959 # == === ======= ======================================================
7960 # 1 yes 2078714 <absolute_path/mxv.hwc.1.thr.er
7961 # 2 yes 2078719 <absolute_path/mxv.hwc.2.thr.er
7962 #------------------------------------------------------------------------------
7963 open (EXP_INFO
, "<", $exp_info_file)
7964 or die ("$subr_name - unable to open file $exp_info_file for reading '$!'");
7965 gp_message
("debug", $subr_name, "opened script file $exp_info_file for reading");
7967 chomp (@exp_info = <EXP_INFO
>);
7969 #------------------------------------------------------------------------------
7970 # TBD - Check for the groups to exist below:
7971 #------------------------------------------------------------------------------
7973 for my $i (0 .. $#exp_info)
7975 my $input_line = $exp_info[$i];
7977 gp_message
("debug", $subr_name, "$i => exp_info[$i] = $exp_info[$i]");
7979 if ($input_line =~ /^\s*(\d+)\s+(.+)/)
7983 $experiment_data[$current_slot]{"exp_id"} = $exp_id;
7984 $experiment_data[$current_slot]{"exp_data_file"} = $outputdir . "gp-info-exp-" . $exp_id . ".out";
7985 gp_message
("debug", $subr_name, $i . " " . $exp_id . " " . $remainder);
7986 if ($remainder =~ /^(\w+)\s+(\d+)\s+(.+)/)
7989 $experiment_data[$current_slot]{"exp_name_full"} = $exp_name;
7990 $experiment_data[$current_slot]{"exp_name_short"} = get_basename
($exp_name);
7992 gp_message
("debug", $subr_name, $i . " " . $1 . " " . $2 . " " . $3);
7996 $msg = "remainder = $remainder has an unexpected format";
7997 gp_message
("assertion", $subr_name, $msg);
8001 #------------------------------------------------------------------------------
8002 # The experiment IDs and names are known. We can now generate the info for
8003 # each individual experiment.
8004 #------------------------------------------------------------------------------
8005 $gp_log_file = $outputdir . $g_gp_output_file;
8006 $gp_error_file = $outputdir . $g_gp_error_logfile;
8008 $script_file = $outputdir . "gp-details-exp.script";
8010 open (SCRIPT_EXPERIMENT_DETAILS
, ">", $script_file)
8011 or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
8012 gp_message
("debug", $subr_name, "opened script file $script_file for writing");
8014 for my $i (sort keys @experiment_data)
8016 my $exp_id = $experiment_data[$i]{"exp_id"};
8018 $result_file = $experiment_data[$i]{"exp_data_file"};
8022 print SCRIPT_EXPERIMENT_DETAILS
"# outfile " . $result_file . "\n";
8023 print SCRIPT_EXPERIMENT_DETAILS
"outfile " . $result_file . "\n";
8024 print SCRIPT_EXPERIMENT_DETAILS
"# header " . $exp_id . "\n";
8025 print SCRIPT_EXPERIMENT_DETAILS
"header " . $exp_id . "\n";
8026 print SCRIPT_EXPERIMENT_DETAILS
"# statistics " . $exp_id . "\n";
8027 print SCRIPT_EXPERIMENT_DETAILS
"statistics " . $exp_id . "\n";
8031 close (SCRIPT_EXPERIMENT_DETAILS
);
8033 $gp_functions_cmd = "$GP_DISPLAY_TEXT -script $script_file $the_experiments";
8035 $msg = "executing $GP_DISPLAY_TEXT to get the experiment details";
8036 gp_message
("debug", $subr_name, $msg);
8038 $gp_display_text_cmd = "$gp_functions_cmd 1>> $gp_log_file 2>> $gp_error_file";
8040 ($error_code, $cmd_output) = execute_system_cmd
($gp_display_text_cmd);
8042 if ($error_code != 0)
8043 #------------------------------------------------------------------------------
8044 # This is unlikely to happen, but you never know.
8045 #------------------------------------------------------------------------------
8047 $ignore_value = msg_display_text_failure
($gp_display_text_cmd,
8050 gp_message
("abort", $subr_name, "execution terminated");
8053 return (\
@experiment_data);
8055 } #-- End of subroutine get_experiment_info
8057 #------------------------------------------------------------------------------
8058 # This subroutine returns a string of the type "size=<n>", where <n> is the
8059 # size of the file passed in. If n > 1024, a unit is appended.
8060 #------------------------------------------------------------------------------
8063 my $subr_name = get_my_name
();
8065 my ($filename) = @_;
8070 if (not -e
$filename)
8072 #------------------------------------------------------------------------------
8073 # The return value is used in the caller. This is why we return the empty
8074 # string in case the file does not exist.
8075 #------------------------------------------------------------------------------
8076 gp_message
("debug", $subr_name, "filename = $filename not found");
8081 $file_stat = stat ($filename);
8082 $size = $file_stat->size;
8084 gp_message
("debug", $subr_name, "filename = $filename");
8085 gp_message
("debug", $subr_name, "size = $size");
8089 if ($size > 1024*1024)
8091 $size = $size/1024/1024;
8104 $size=$size." bytes";
8106 gp_message
("debug", $subr_name, "size = $size title=\"$size\"");
8108 return ("title=\"$size\"");
8111 } #-- End of subroutine getfilesize
8113 #------------------------------------------------------------------------------
8114 # Parse the fsummary output and for all functions, store all the information
8115 # found in "function_info". In addition to this, several derived structures
8116 # are stored as well, making this structure a "onestop" place to get all the
8117 # info that is needed.
8118 #------------------------------------------------------------------------------
8119 sub get_function_info
8121 my $subr_name = get_my_name
();
8123 my ($FSUMMARY_FILE) = @_;
8125 #------------------------------------------------------------------------------
8126 # The regex section.
8127 #------------------------------------------------------------------------------
8128 my $white_space_regex = '\s*';
8130 my @function_info = ();
8131 my %function_address_and_index = ();
8132 my %LINUX_vDSO = ();
8133 my %function_view_structure = ();
8134 my %addressobjtextm = ();
8135 #------------------------------------------------------------------------------
8136 # TBD: This structure is no longer used and most likely can be removed.
8137 #------------------------------------------------------------------------------
8138 my %functions_index = ();
8143 my $full_address_field;
8144 my %source_files = ();
8152 my $address_decimal;
8155 my $num_source_files = 0;
8156 my $number_of_functions = 0;
8157 my $number_of_unique_functions = 0;
8158 my $number_of_non_unique_functions = 0;
8160 #------------------------------------------------------------------------------
8161 # Open the file generated using the -fsummary option.
8162 #------------------------------------------------------------------------------
8163 open (FSUMMARY_FILE
, "<", $FSUMMARY_FILE)
8164 or die ("$subr_name - unable to open $FSUMMARY_FILE for reading: '$!'");
8165 gp_message
("debug", $subr_name, "opened file $FSUMMARY_FILE for reading");
8167 #------------------------------------------------------------------------------
8168 # This is the typical structure of the fsummary output:
8170 # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
8171 # Functions sorted by metric: Exclusive Total CPU Time
8174 # Exclusive Total CPU Time: 11.538 (100.0%)
8175 # Inclusive Total CPU Time: 11.538 (100.0%)
8177 # PC Address: 1:0x00000000
8178 # Source File: (unknown)
8179 # Object File: (unknown)
8180 # Load Object: <Total>
8185 # Exclusive Total CPU Time: 4.003 ( 34.7%)
8186 # Inclusive Total CPU Time: 4.003 ( 34.7%)
8188 # PC Address: 2:0x00006c61
8189 # Source File: <absolute path to source file>
8190 # Object File: <object filename>
8191 # Load Object: <executable name>
8195 # The previous block is repeated for every function.
8196 #------------------------------------------------------------------------------
8198 #------------------------------------------------------------------------------
8199 # Skip the header. The header is defined to end with a blank line.
8200 #------------------------------------------------------------------------------
8201 while (<FSUMMARY_FILE
>)
8205 if ($line =~ /^\s*$/)
8211 #------------------------------------------------------------------------------
8212 # Process the remaining blocks. Note that the first line should be <Total>,
8213 # but this is currently not checked.
8214 #------------------------------------------------------------------------------
8216 $routine_flag = $TRUE;
8217 while (<FSUMMARY_FILE
>)
8221 gp_message
("debugXL", $subr_name, "line = $line");
8223 if ($line =~ /^\s*$/)
8224 #------------------------------------------------------------------------------
8226 #------------------------------------------------------------------------------
8228 $routine_flag = $TRUE;
8231 #------------------------------------------------------------------------------
8232 # Linux vDSO exception
8234 # TBD: Check if still relevant.
8235 #------------------------------------------------------------------------------
8236 if ($function_info[$i]{"Load Object"} eq "DYNAMIC_FUNCTIONS")
8238 $LINUX_vDSO{substr ($function_info[$i]{"addressobjtext"},1)} = $function_info[$i]{"routine"};
8245 #------------------------------------------------------------------------------
8246 # Should be the first line after the blank line.
8247 #------------------------------------------------------------------------------
8250 push (@
{ $g_map_function_to_index{$routine} }, $i);
8251 gp_message
("debugXL", $subr_name, "pushed i = $i to g_map_function_to_index{$routine}");
8253 #------------------------------------------------------------------------------
8254 # In a later parsing phase we need to know how many fields there are in a
8255 # function name. For example, "<static>@0x21850 (<libc-2.28.so>)" is name that
8256 # may show up in a function list.
8258 # Here we determine the number of fields and store it.
8259 #------------------------------------------------------------------------------
8260 my @fields_in_name = split (" ", $routine);
8261 $function_info[$i]{"fields in routine name"} = scalar (@fields_in_name);
8263 #------------------------------------------------------------------------------
8264 # This name may change if the function has multiple occurrences, but in any
8265 # case, at the end of this routine this component has the final name to be
8267 #------------------------------------------------------------------------------
8268 $function_info[$i]{"alt_name"} = $routine;
8269 if (not exists ($g_function_occurrences{$routine}))
8271 gp_message
("debugXL", $subr_name, "the entry in function_info for $routine does not exist");
8272 $function_info[$i]{"routine"} = $routine;
8273 $g_function_occurrences{$routine} = 1;
8275 gp_message
("debugXL", $subr_name, "g_function_occurrences{$routine} = $g_function_occurrences{$routine}");
8279 gp_message
("debugXL", $subr_name, "the entry in function_info for $routine exists already");
8280 $function_info[$i]{"routine"} = $routine;
8281 $g_function_occurrences{$routine} += 1;
8282 if (not exists ($g_multi_count_function{$routine}))
8284 $g_multi_count_function{$routine} = $TRUE;
8286 $msg = "g_function_occurrences{$routine} = ";
8287 $msg .= $g_function_occurrences{$routine};
8288 gp_message
("debugXL", $subr_name, $msg);
8290 #------------------------------------------------------------------------------
8291 # New: used when generating the index.
8292 #------------------------------------------------------------------------------
8293 $function_info[$i]{"function length"} = length ($routine);
8294 $function_info[$i]{"tag_id"} = create_function_tag
($i);
8295 if (not exists ($g_function_tag_id{$routine}))
8297 $g_function_tag_id{$routine} = create_function_tag
($i);
8302 #------------------------------------------------------------------------------
8303 ## TBD HACK!!! CHECK!!!!!
8304 #------------------------------------------------------------------------------
8305 $g_function_tag_id{$routine} = $i;
8308 $routine_flag = $FALSE;
8309 gp_message
("debugXL", $subr_name, "stored " . $function_info[$i]{"routine"});
8311 #------------------------------------------------------------------------------
8312 # The $functions_index hash contains an array. After an initial assignment,
8313 # other values that have been found are pushed onto the arrays.
8314 #------------------------------------------------------------------------------
8315 if (not exists ($functions_index{$routine}))
8317 $functions_index{$routine} = [$i];
8321 #------------------------------------------------------------------------------
8322 # Add the array index to the list
8323 #------------------------------------------------------------------------------
8324 push (@
{$functions_index{$routine}}, $i);
8329 #------------------------------------------------------------------------------
8330 # Expected format of an input line:
8331 # Exclusive Total CPU Time: 4.003 ( 34.7%)
8333 # Source File: <absolute_path>/name_of_source_file
8334 #------------------------------------------------------------------------------
8337 my @input_fields = split (":", $line);
8338 my $no_of_elements = scalar (@input_fields);
8340 gp_message
("debugXL", $subr_name, "#input_fields = $#input_fields");
8341 gp_message
("debugXL", $subr_name, "no_of_elements = $no_of_elements");
8342 gp_message
("debugXL", $subr_name, "input_fields[0] = $input_fields[0]");
8344 if ($no_of_elements == 1)
8346 $whatever = $input_fields[0];
8349 elsif ($no_of_elements == 2)
8351 #------------------------------------------------------------------------------
8352 # Note that value may consist of multiple fields (e.g. 1.651 ( 95.4%)).
8353 #------------------------------------------------------------------------------
8354 $whatever = $input_fields[0];
8355 $value = $input_fields[1];
8357 elsif ($no_of_elements == 3)
8359 #------------------------------------------------------------------------------
8360 # Assumption: must be an address field. Restore the second colon.
8361 #------------------------------------------------------------------------------
8362 $whatever = $input_fields[0];
8363 $value = $input_fields[1] . ":" . $input_fields[2];
8367 $msg = "unexpected: number of fields = " . $no_of_elements;
8368 gp_message
("assertion", $subr_name, $msg);
8370 #------------------------------------------------------------------------------
8371 # Remove any leading whitespace characters.
8372 #------------------------------------------------------------------------------
8373 $value =~ s/$white_space_regex//;
8375 gp_message
("debugXL", $subr_name, "whatever = $whatever value = $value");
8377 $function_info[$i]{$whatever} = $value;
8379 #------------------------------------------------------------------------------
8380 # TBD: Seems to be not used anymore and can most likely be removed. Check this.
8381 #------------------------------------------------------------------------------
8382 if ($whatever =~ /Source File/)
8384 if (!exists ($source_files{$value}))
8386 $source_files{$value} = $TRUE;
8387 $num_source_files++;
8391 if ($whatever =~ /PC Address/)
8395 #------------------------------------------------------------------------------
8396 # The format of the address is assumed to be the following 2:0x000070a8
8397 # Note that the regex is pretty wide. This is from the original code and
8398 # could be made more specific:
8399 # if ($value =~ /\s*(\S+):(\S+)/)
8400 #------------------------------------------------------------------------------
8401 # if ($value =~ /\s*(\S+):(\S+)/)
8402 if ($value =~ /\s*(\d+):0x([0-9a-zA-Z]+)/)
8406 #------------------------------------------------------------------------------
8407 # Convert to a base 10 number
8408 #------------------------------------------------------------------------------
8409 $address_decimal = bigint
::hex ($offset); # decimal
8410 #------------------------------------------------------------------------------
8411 # Construct the address field. Note that we use the hex address here.
8412 # For example @2:0x0003f280
8413 #------------------------------------------------------------------------------
8414 $full_address_field = '@'.$segment.":0x".$offset;
8416 $function_info[$i]{"addressobj"} = $address_decimal;
8417 $function_info[$i]{"addressobjtext"} = $full_address_field;
8418 $addressobjtextm{$full_address_field} = $i; # $RI
8420 if (not exists ($function_address_and_index{$routine}{$value}))
8422 $function_address_and_index{$routine}{$value} = $i;
8424 $msg = "function_address_and_index{$routine}{$value} = ";
8425 $msg .= $function_address_and_index{$routine}{$value};
8426 gp_message
("debugXL", $subr_name, $msg);
8430 $msg = "function_info: $FSUMMARY_FILE: function $routine";
8431 $msg .= " already has a PC Address";
8432 gp_message
("debugXL", $subr_name, $msg);
8435 $number_of_functions++;
8438 close (FSUMMARY_FILE
);
8440 #------------------------------------------------------------------------------
8441 # For every function in the function overview, set up an html structure with
8442 # the various hyperlinks.
8443 #------------------------------------------------------------------------------
8444 gp_message
("debugXL", $subr_name, "augment function_info with alt_name");
8445 my $target_function;
8449 my %html_source_functions = ();
8450 for my $i (keys @function_info)
8452 $target_function = $function_info[$i]{"routine"};
8454 gp_message
("debugXL", $subr_name, "i = $i target_function = $target_function");
8457 ## $href_link = "<a href=\'file." . $i . ".src.new.html#";
8458 $href_link = "<a href=\'file." . $i . ".";
8459 $href_link .= $g_html_base_file_name{"source"};
8460 $href_link .= ".html#";
8461 $href_link .= $function_info[$i]{"tag_id"};
8462 $href_link .= "\'>source</a>";
8463 $function_info[$i]{"href_source"} = $href_link;
8465 $href_link = "<a href=\'file." . $i . ".";
8466 $href_link .= $g_html_base_file_name{"disassembly"};
8467 $href_link .= ".html#";
8468 $href_link .= $function_info[$i]{"tag_id"};
8469 $href_link .= "\'>disassembly</a>";
8470 $function_info[$i]{"href_disassembly"} = $href_link;
8472 $href_link = "<a href=\'";
8473 $href_link .= $g_html_base_file_name{"caller_callee"};
8474 $href_link .= ".html#";
8475 $href_link .= $function_info[$i]{"tag_id"};
8476 $href_link .= "\'>caller-callee</a>";
8477 $function_info[$i]{"href_caller_callee"} = $href_link;
8479 gp_message
("debug", $subr_name, "g_function_occurrences{$target_function} = $g_function_occurrences{$target_function}");
8481 if ($g_function_occurrences{$target_function} > 1)
8483 #------------------------------------------------------------------------------
8484 # In case a function occurs more than one time in the function overview, we
8485 # add the load object and address offset info to make it unique.
8487 # This forces us to update some entries in function_info too.
8488 #------------------------------------------------------------------------------
8489 my $loadobj = $function_info[$i]{"Load Object"};
8490 my $address_field = $function_info[$i]{"addressobjtext"};
8493 #------------------------------------------------------------------------------
8494 # The address field has the following format: @<n>:<address_offset>
8495 # We only care about the address offset.
8496 #------------------------------------------------------------------------------
8497 if ($address_field =~ /(^@\d*:*)(.+)/)
8499 $address_offset = $2;
8503 my $msg = "failed to extract the address offset from $address_field - use the full field";
8504 gp_message
("warning", $subr_name, $msg);
8505 $address_offset = $address_field;
8507 my $exe = get_basename
($loadobj);
8508 my $extra_field = " (<" . $exe . " $address_offset" .">)";
8509 ### $target_function .= $extra_field;
8510 $function_info[$i]{"alt_name"} = $target_function . $extra_field;
8511 gp_message
("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"});
8513 #------------------------------------------------------------------------------
8514 # Store the length of the function name and get the tag id.
8515 #------------------------------------------------------------------------------
8516 $function_info[$i]{"function length"} = length ($target_function . $extra_field);
8517 $function_info[$i]{"tag_id"} = create_function_tag
($i);
8519 gp_message
("debugXL", $subr_name, "updated function_info[$i]{'routine'} = $function_info[$i]{'routine'}");
8520 gp_message
("debugXL", $subr_name, "updated function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}");
8521 gp_message
("debugXL", $subr_name, "updated function_info[$i]{'function length'} = $function_info[$i]{'function length'}");
8522 gp_message
("debugXL", $subr_name, "updated function_info[$i]{'tag_id'} = $function_info[$i]{'tag_id'}");
8525 gp_message
("debug", $subr_name, "augment function_info with alt_name completed");
8527 #------------------------------------------------------------------------------
8528 # Compute the maximum function name length.
8530 # The maximum length is stored in %function_view_structure.
8531 #------------------------------------------------------------------------------
8532 my $max_function_length = 0;
8533 for my $i (0 .. $#function_info)
8535 $max_function_length = List
::Util
::max
($max_function_length, $function_info[$i]{"function length"});
8537 gp_message
("debugXL", $subr_name, "function_info[$i]{\"alt_name\"} = " . $function_info[$i]{"alt_name"} . " length = " . $function_info[$i]{"function length"});
8540 #------------------------------------------------------------------------------
8541 # Define the name of the table and take the length into account, since it may
8542 # be longer than the function name(s).
8543 #------------------------------------------------------------------------------
8544 $function_view_structure{"table name"} = "Function name";
8546 $max_function_length = max
($max_function_length, length ($function_view_structure{"table name"}));
8548 $function_view_structure{"max function length"} = $max_function_length;
8550 #------------------------------------------------------------------------------
8551 # Core loop that generates an HTML line for each function. This line is
8552 # stored in function_info.
8553 #------------------------------------------------------------------------------
8554 my $top_of_table = $FALSE;
8555 for my $i (keys @function_info)
8557 my $new_target_function;
8559 if (defined ($function_info[$i]{"alt_name"}))
8561 $target_function = $function_info[$i]{"alt_name"};
8562 gp_message
("debugXL", $subr_name, "retrieved function_info[$i]{'alt_name'} = $function_info[$i]{'alt_name'}");
8566 my $msg = "function_info[$i]{\"alt_name\"} is not defined";
8567 gp_message
("assertion", $subr_name, $msg);
8570 my $function_length = $function_info[$i]{"function length"};
8571 my $number_of_blanks = $function_view_structure{"max function length"} - $function_length;
8573 my $spaces = " ";
8574 for my $i (1 .. $number_of_blanks)
8576 $spaces .= " ";
8578 if ($target_function eq "<Total>")
8579 #------------------------------------------------------------------------------
8580 # <Total> is a pseudo function and there is no source, or disassembly for it.
8581 # We could add a link to the caller-callee part, but this is currently not
8583 #------------------------------------------------------------------------------
8585 $top_of_table = $TRUE;
8586 $html_line = " <b><Total></b>";
8590 #------------------------------------------------------------------------------
8591 # Add the * symbol as a marker in case the same function occurs multiple times.
8592 # Otherwise insert a space.
8593 #------------------------------------------------------------------------------
8594 my $base_function_name = $function_info[$i]{"routine"};
8595 if (exists ($g_function_occurrences{$base_function_name}))
8597 if ($g_function_occurrences{$base_function_name} > 1)
8599 $new_target_function = "*" . $target_function;
8603 $new_target_function = " " . $target_function;
8608 my $msg = "g_function_occurrences{$base_function_name} does not exist";
8609 gp_message
("assertion", $subr_name, $msg);
8612 #------------------------------------------------------------------------------
8613 # Create the block with the function name, in boldface, plus the links to the
8614 # source, disassembly and caller-callee views.
8615 #------------------------------------------------------------------------------
8617 #------------------------------------------------------------------------------
8618 # We need to replace the "<" symbol in the code by "<".
8619 #------------------------------------------------------------------------------
8620 $new_target_function =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
8622 $html_line = "<b>$new_target_function</b>" . $spaces;
8623 $html_line .= $function_info[$i]{"href_source"} . " ";
8624 $html_line .= $function_info[$i]{"href_disassembly"} . " ";
8625 $html_line .= $function_info[$i]{"href_caller_callee"};
8628 $msg = "target_function = $target_function html_line = $html_line";
8629 gp_message
("debugM", $subr_name, $msg);
8630 $html_source_functions{$target_function} = $html_line;
8632 #------------------------------------------------------------------------------
8633 # TBD: In the future we want to re-use this block elsewhere.
8634 #------------------------------------------------------------------------------
8635 $function_info[$i]{"html function block"} = $html_line;
8638 for my $i (keys %html_source_functions)
8640 $msg = "html_source_functions{$i} = $html_source_functions{$i}";
8641 gp_message
("debugM", $subr_name, $msg);
8643 for my $i (keys @function_info)
8645 $msg = "function_info[$i]{\"html function block\"} = ";
8646 $msg .= $function_info[$i]{"html function block"};
8647 gp_message
("debugM", $subr_name, $msg);
8650 #------------------------------------------------------------------------------
8651 # Print the key data structure %function_info. This is a nested hash.
8652 #------------------------------------------------------------------------------
8653 for my $i (0 .. $#function_info)
8655 for my $role (sort keys %{ $function_info[$i] })
8657 $msg = "on return: function_info[$i]{$role} = ";
8658 $msg .= $function_info[$i]{$role};
8659 gp_message
("debugM", $subr_name, $msg);
8662 #------------------------------------------------------------------------------
8663 # Print the data structure %function_address_and_index. This is a nested hash.
8664 #------------------------------------------------------------------------------
8665 for my $F (keys %function_address_and_index)
8667 for my $fields (sort keys %{ $function_address_and_index{$F} })
8669 $msg = "on return: function_address_and_index{$F}{$fields} = ";
8670 $msg .= $function_address_and_index{$F}{$fields};
8671 gp_message
("debugM", $subr_name, $msg);
8674 #------------------------------------------------------------------------------
8675 # Print the data structure %functions_index. This is a hash with an arrray.
8676 #------------------------------------------------------------------------------
8677 for my $F (keys %functions_index)
8679 gp_message
("debug", $subr_name, "on return: functions_index{$F} = @{ $functions_index{$F} }");
8680 # alt code for my $i (0 .. $#{ $functions_index{$F} } )
8682 # alt code gp_message ("debug", $subr_name, "on return: \$functions_index{$F} = $functions_index{$F}[$i]");
8686 #------------------------------------------------------------------------------
8687 # Print the data structure %function_view_structure. This is a hash.
8688 #------------------------------------------------------------------------------
8689 for my $F (keys %function_view_structure)
8691 gp_message
("debug", $subr_name, "on return: function_view_structure{$F} = $function_view_structure{$F}");
8694 #------------------------------------------------------------------------------
8695 # Print the data structure %g_function_occurrences and use this structure to
8696 # gather statistics about the functions.
8698 # TBD: add this info to the experiment data overview.
8699 #------------------------------------------------------------------------------
8700 $number_of_unique_functions = 0;
8701 $number_of_non_unique_functions = 0;
8702 for my $F (keys %g_function_occurrences)
8704 gp_message
("debug", $subr_name, "on return: g_function_occurrences{$F} = $g_function_occurrences{$F}");
8705 if ($g_function_occurrences{$F} == 1)
8707 $number_of_unique_functions++;
8711 $number_of_non_unique_functions++;
8715 for my $i (keys %g_map_function_to_index)
8717 my $n = scalar (@
{ $g_map_function_to_index{$i} });
8718 gp_message
("debug", $subr_name, "on return: g_map_function_to_index [$n] : $i => @{ $g_map_function_to_index{$i} }");
8721 #------------------------------------------------------------------------------
8722 # TBD: Include in experiment data. Include names with multiple occurrences.
8723 #------------------------------------------------------------------------------
8724 $msg = "Number of source files : " .
8726 gp_message
("debug", $subr_name, $msg);
8727 $msg = "Total number of functions: $number_of_functions";
8728 gp_message
("debug", $subr_name, $msg);
8729 $msg = "Number of functions functions with a unique name : " .
8730 $number_of_unique_functions;
8731 gp_message
("debug", $subr_name, $msg);
8732 $msg = "Number of functions functions with more than one occurrence : " .
8733 $number_of_non_unique_functions;
8734 gp_message
("debug", $subr_name, $msg);
8735 my $multi_occurrences = $number_of_functions - $number_of_unique_functions;
8736 $msg = "Total number of multiple occurences of the same function name : " .
8738 gp_message
("debug", $subr_name, $msg);
8740 return (\
@function_info, \
%function_address_and_index, \
%addressobjtextm,
8741 \
%LINUX_vDSO, \
%function_view_structure);
8743 } #-- End of subroutine get_function_info
8744 #------------------------------------------------------------------------------
8746 #------------------------------------------------------------------------------
8749 my $subr_name = get_my_name
();
8751 my ($outputdir, $file) = @_;
8753 state $first_call = $TRUE;
8760 my $ignore_directory;
8762 my $number_of_header_lines;
8764 #------------------------------------------------------------------------------
8765 # Add a "/" to simplify the construction of path names in the remainder.
8766 #------------------------------------------------------------------------------
8767 $outputdir = append_forward_slash
($outputdir);
8769 # Could get more header info from
8770 # <metric>[e.bit_fcount].sort.func file - etc.
8772 gp_message
("debug", $subr_name, "input file->$file<-");
8773 #-----------------------------------------------
8774 if ($file eq $outputdir."calls.sort.func")
8776 $ASORTFILE=$outputdir."calls";
8779 elsif ($file eq $outputdir."calltree.sort.func")
8781 $ASORTFILE=$outputdir."calltree";
8782 $metric = "calltree"
8784 elsif ($file eq $outputdir."functions.sort.func")
8786 $ASORTFILE=$outputdir."functions.func";
8787 $metric = "functions";
8792 # $metric = basename ($file,".sort.func");
8793 ($metric, $ignore_directory, $ignore_suffix) = fileparse
($file, ".sort.func");
8794 gp_message
("debug", $subr_name, "ignore_directory = $ignore_directory ignore_suffix = $ignore_suffix");
8797 gp_message
("debug", $subr_name, "file = $file metric = $metric");
8799 open (ASORTFILE
,"<", $ASORTFILE)
8800 or die ("$subr_name - unable to open file $ASORTFILE for reading: '$!'");
8801 gp_message
("debug", $subr_name, "opened file $ASORTFILE for reading");
8803 $number_of_header_lines = 0;
8809 if ($line =~ /^Current/)
8813 if ($line =~ /^Functions/)
8817 if ($line =~ /^Callers/)
8821 if ($line =~ /^\s*$/)
8825 if (!($line =~ /^\s*\d/))
8827 $HDR[$number_of_header_lines] = $line;
8828 $number_of_header_lines++;
8834 #------------------------------------------------------------------------------
8835 # Ruud - Fixed a bug. The output should not be appended, but overwritten.
8836 # open (HI,">>$OUTPUTDIR"."hdrinfo");
8837 #------------------------------------------------------------------------------
8838 my $outfile = $outputdir."hdrinfo";
8842 $first_call = $FALSE;
8843 open (HI
,">", $outfile)
8844 or die ("$subr_name - unable to open file $outfile for writing: '$!'");
8845 gp_message
("debug", $subr_name, "opened file $outfile for writing");
8849 open (HI
,">>", $outfile)
8850 or die ("$subr_name - unable to open file $outfile in append mode: '$!'");
8851 gp_message
("debug", $subr_name, "opened file $outfile in append mode");
8854 print HI
"\#$metric hdrlines=$number_of_header_lines\n";
8859 gp_message
("debugXL", $subr_name, "HDR = $HDR\n");
8864 gp_message
("debug", $subr_name, "wrote file $outfile");
8868 gp_message
("debug", $subr_name, "updated file $outfile");
8870 #-----------------------------------------------
8872 } #-- End of subroutine get_hdr_info
8874 #------------------------------------------------------------------------------
8875 # Get the home directory and the location(s) of the configuration file on the
8877 #------------------------------------------------------------------------------
8878 sub get_home_dir_and_rc_path
8880 my $subr_name = get_my_name
();
8882 my ($rc_file_name) = @_;
8889 $target_cmd = $g_mapped_cmds{"printenv"} . " HOME";
8891 ($error_code, $home_dir) = execute_system_cmd
($target_cmd);
8893 if ($error_code != 0)
8895 my $msg = "cannot find a setting for HOME - please set this";
8896 gp_message
("assertion", $subr_name, $msg);
8900 #------------------------------------------------------------------------------
8901 # The home directory is known and we can define the locations for the
8902 # configuration file.
8903 #------------------------------------------------------------------------------
8905 @rc_file_paths = (".", "$home_dir");
8908 gp_message
("debug", $subr_name, "upon return: \@rc_file_paths = @rc_file_paths");
8910 return ($home_dir, \
@rc_file_paths);
8912 } #-- End of subroutine get_home_dir_and_rc_path
8914 #------------------------------------------------------------------------------
8915 # This subroutine generates a list with the hot functions.
8916 #------------------------------------------------------------------------------
8917 sub get_hot_functions
8919 my $subr_name = get_my_name
();
8921 my ($exp_dir_list_ref, $summary_metrics, $input_string) = @_;
8923 my @exp_dir_list = @
{ $exp_dir_list_ref };
8929 my $gp_display_text_cmd;
8932 my @sort_fields = ();
8934 $expr_name = join (" ", @exp_dir_list);
8936 gp_message
("debug", $subr_name, "expr_name = $expr_name");
8938 my $outputdir = append_forward_slash
($input_string);
8940 my $script_file = $outputdir."gp-fsummary.script";
8941 my $outfile = $outputdir."gp-fsummary.out";
8942 my $result_file = $outputdir."gp-fsummary.stderr";
8943 my $gp_error_file = $outputdir.$g_gp_error_logfile;
8945 @sort_fields = split (":", $summary_metrics);
8947 #------------------------------------------------------------------------------
8948 # This is extremely unlikely to happen, but if so, it is a fatal error.
8949 #------------------------------------------------------------------------------
8950 my $number_of_elements = scalar (@sort_fields);
8952 gp_message
("debug", $subr_name, "number of fields in summary_metrics = $number_of_elements");
8954 if ($number_of_elements == 0)
8956 my $msg = "there are $number_of_elements in the metrics list";
8957 gp_message
("assertion", $subr_name, $msg);
8960 #------------------------------------------------------------------------------
8961 # Get the summary of the hot functions
8962 #------------------------------------------------------------------------------
8963 open (SCRIPT
, ">", $script_file)
8964 or die ("$subr_name - unable to open script file $script_file for writing: '$!'");
8965 gp_message
("debug", $subr_name, "opened script file $script_file for writing");
8967 #------------------------------------------------------------------------------
8968 # TBD: Check what this is about:
8969 # Attributed User CPU Time=a.user : for calltree - see P37 in manual
8970 #------------------------------------------------------------------------------
8971 print SCRIPT
"# limit 0\n";
8972 print SCRIPT
"limit 0\n";
8973 print SCRIPT
"# metrics $summary_metrics\n";
8974 print SCRIPT
"metrics $summary_metrics\n";
8975 print SCRIPT
"# thread_select all\n";
8976 print SCRIPT
"thread_select all\n";
8978 #------------------------------------------------------------------------------
8979 # Use first out of summary metrics as first (it doesn't matter which one)
8980 # $first_metric = (split /:/,$summary_metrics)[0];
8981 #------------------------------------------------------------------------------
8983 $first_metric = $sort_fields[0];
8985 print SCRIPT
"# outfile $outfile\n";
8986 print SCRIPT
"outfile $outfile\n";
8987 print SCRIPT
"# sort $first_metric\n";
8988 print SCRIPT
"sort $first_metric\n";
8989 print SCRIPT
"# fsummary\n";
8990 print SCRIPT
"fsummary\n";
8994 my $gp_functions_cmd = "$GP_DISPLAY_TEXT -viewmode machine -compare off -script $script_file $expr_name";
8996 gp_message
("debug", $subr_name, "executing $GP_DISPLAY_TEXT to get the list of functions");
8998 $gp_display_text_cmd = "$gp_functions_cmd 1> $result_file 2>> $gp_error_file";
9000 ($error_code, $cmd_output) = execute_system_cmd
($gp_display_text_cmd);
9002 if ($error_code != 0)
9004 $ignore_value = msg_display_text_failure
($gp_display_text_cmd,
9007 gp_message
("abort", $subr_name, "execution terminated");
9008 my $msg = "error code = $error_code - failure executing command $gp_display_text_cmd";
9009 gp_message
("abort", $subr_name, $msg);
9012 return ($outfile,\
@sort_fields);
9014 } #-- End of subroutine get_hot_functions
9016 #------------------------------------------------------------------------------
9017 # For a given function name, return the index into "function_info". This
9018 # index gives access to all the meta data for the input function.
9019 #------------------------------------------------------------------------------
9020 sub get_index_function_info
9022 my $subr_name = get_my_name
();
9024 my ($routine_ref, $hex_address_ref, $function_info_ref) = @_;
9026 my $routine = ${ $routine_ref };
9027 my $hex_address = ${ $hex_address_ref };
9028 my @function_info = @
{ $function_info_ref };
9030 #------------------------------------------------------------------------------
9031 # Check if this function has multiple occurrences.
9032 #------------------------------------------------------------------------------
9033 gp_message
("debug", $subr_name, "check for multiple occurrences");
9035 my $current_address = $hex_address;
9036 my $alt_name = $routine;
9039 my $index_into_function_info;
9042 if (not exists ($g_multi_count_function{$routine}))
9044 #------------------------------------------------------------------------------
9045 # There is only a single occurrence and it is straightforward to get the tag.
9046 #--------------------------------------------------------------------------
9047 ## push (@final_function_names, $routine);
9048 if (exists ($g_map_function_to_index{$routine}))
9050 $index_into_function_info = $g_map_function_to_index{$routine}[0];
9054 my $msg = "no entry for $routine in g_map_function_to_index";
9055 gp_message
("assertion", $subr_name, $msg);
9060 #------------------------------------------------------------------------------
9061 # The function name has more than one occurrence and we need to find the one
9062 # that matches with the address.
9063 #------------------------------------------------------------------------------
9064 $found_a_match = $FALSE;
9065 gp_message
("debug", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
9066 for my $ref (keys @
{ $g_map_function_to_index{$routine} })
9068 my $ref_index = $g_map_function_to_index{$routine}[$ref];
9069 my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
9071 gp_message
("debug", $subr_name, "$routine: retrieving duplicate entry at ref_index = $ref_index");
9072 gp_message
("debug", $subr_name, "$routine: addr_offset = $addr_offset");
9074 #------------------------------------------------------------------------------
9075 # TBD: Do this substitution when storing "addressobjtext" in function_info.
9076 #------------------------------------------------------------------------------
9077 $addr_offset =~ s/^@\d+://;
9078 gp_message
("debug", $subr_name, "$routine: addr_offset = $addr_offset");
9079 if ($addr_offset eq $current_address)
9081 $found_a_match = $TRUE;
9082 $index_into_function_info = $ref_index;
9087 #------------------------------------------------------------------------------
9088 # If there is no match, something has gone really wrong and we bail out.
9089 #------------------------------------------------------------------------------
9090 if (not $found_a_match)
9092 my $msg = "cannot find the mapping in function_info for function $routine";
9093 gp_message
("assertion", $subr_name, $msg);
9097 return (\
$index_into_function_info);
9099 } #-- End of subroutine get_index_function_info
9101 #------------------------------------------------------------------------------
9102 # Get the setting for LANG, or assign a default if it is not set.
9103 #------------------------------------------------------------------------------
9104 sub get_LANG_setting
9106 my $subr_name = get_my_name
();
9114 $target_cmd = $g_mapped_cmds{"printenv"};
9115 #------------------------------------------------------------------------------
9116 # Use the printenv command to get the settings for LANG.
9117 #------------------------------------------------------------------------------
9118 if ($target_cmd eq "road to nowhere")
9124 $command_string = $target_cmd . " LANG";
9125 ($error_code, $lang_setting) = execute_system_cmd
($command_string);
9128 if ($error_code == 0)
9130 chomp ($lang_setting);
9131 $LANG = $lang_setting;
9135 $LANG = $g_default_setting_lang;
9136 my $msg = "cannot find a setting for LANG - use a default setting";
9137 gp_message
("warning", $subr_name, $msg);
9142 } #-- End of subroutine get_LANG_setting
9144 #------------------------------------------------------------------------------
9145 # This subroutine gathers the basic information about the metrics.
9146 #------------------------------------------------------------------------------
9147 sub get_metrics_data
9149 my $subr_name = get_my_name
();
9151 my ($exp_dir_list_ref, $outputdir, $outfile1, $outfile2, $error_file) = @_;
9153 my @exp_dir_list = @
{ $exp_dir_list_ref };
9163 $expr_name = join (" ", @exp_dir_list);
9165 gp_message
("debug", $subr_name, "expr_name = $expr_name");
9167 #------------------------------------------------------------------------------
9168 # Execute the $GP_DISPLAY_TEXT tool with the appropriate options. The goal is
9169 # to get all the output in files $outfile1 and $outfile2. These are then
9171 #------------------------------------------------------------------------------
9172 $cmd_options = " -viewmode machine -compare off -thread_select all";
9173 $cmd_options .= " -outfile $outfile2";
9174 $cmd_options .= " -fsingle '<Total>' -metric_list $expr_name";
9176 $metrics_cmd = "$GP_DISPLAY_TEXT $cmd_options 1> $outfile1 2> $error_file";
9178 gp_message
("debug", $subr_name, "command used to gather the information:");
9179 gp_message
("debug", $subr_name, $metrics_cmd);
9181 ($error_code, $metrics_output) = execute_system_cmd
($metrics_cmd);
9183 #------------------------------------------------------------------------------
9184 # Error handling. Any error that occurred is fatal and execution
9185 # should be aborted by the caller.
9186 #------------------------------------------------------------------------------
9187 if ($error_code == 0)
9189 gp_message
("debug", $subr_name, "metrics data in files $outfile1 and $outfile2");
9193 $target_cmd = $g_mapped_cmds{"cat"} . " $error_file";
9195 ($error_code, $cmd_output) = execute_system_cmd
($target_cmd);
9197 chomp ($cmd_output);
9199 gp_message
("error", $subr_name, "contents of file $error_file:");
9200 gp_message
("error", $subr_name, $cmd_output);
9203 return ($error_code);
9205 } #-- End of subroutine get_metrics_data
9207 #------------------------------------------------------------------------------
9208 # Wrapper that returns the last part of the subroutine name. The assumption is
9209 # that the last part of the input name is of the form "aa::bb" or just "bb".
9210 #------------------------------------------------------------------------------
9213 my $called_by = (caller (1))[3];
9214 my @parts = split ("::", $called_by);
9215 return ($parts[$#parts]);
9217 ## my ($the_full_name_ref) = @_;
9219 ## my $the_full_name = ${ $the_full_name_ref };
9222 #------------------------------------------------------------------------------
9223 # If the regex below fails, use the full name."
9224 #------------------------------------------------------------------------------
9225 ## $last_part = $the_full_name;
9227 #------------------------------------------------------------------------------
9228 # Capture the last part if there are multiple parts separated by "::".
9229 #------------------------------------------------------------------------------
9230 ## if ($the_full_name =~ /.*::(.+)$/)
9232 ## if (defined ($1))
9238 ## return (\$last_part);
9240 } #-- End of subroutine get_my_name
9242 #------------------------------------------------------------------------------
9243 # Determine the characteristics of the current system
9244 #------------------------------------------------------------------------------
9245 sub get_system_config_info
9247 #------------------------------------------------------------------------------
9248 # The output from the "uname" command is used for this. Although not all of
9249 # these are currently used, we store all fields in separate variables.
9250 #------------------------------------------------------------------------------
9252 #------------------------------------------------------------------------------
9253 # The options supported on uname from GNU coreutils 8.22:
9254 #------------------------------------------------------------------------------
9255 # -a, --all print all information, in the following order,
9256 # except omit -p and -i if unknown:
9257 # -s, --kernel-name print the kernel name
9258 # -n, --nodename print the network node hostname
9259 # -r, --kernel-release print the kernel release
9260 # -v, --kernel-version print the kernel version
9261 # -m, --machine print the machine hardware name
9262 # -p, --processor print the processor type or "unknown"
9263 # -i, --hardware-platform print the hardware platform or "unknown"
9264 # -o, --operating-system print the operating system
9265 #------------------------------------------------------------------------------
9267 # 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
9268 #------------------------------------------------------------------------------
9269 my $subr_name = get_my_name
();
9272 my $hostname_current;
9276 #------------------------------------------------------------------------------
9277 # Test once if the command succeeds. This avoids we need to check every
9278 # specific # command below.
9279 #------------------------------------------------------------------------------
9280 $target_cmd = $g_mapped_cmds{uname
};
9281 ($error_code, $ignore_output) = execute_system_cmd
($target_cmd);
9283 if ($error_code != 0)
9284 #------------------------------------------------------------------------------
9285 # This is unlikely to happen, but you never know.
9286 #------------------------------------------------------------------------------
9288 gp_message
("abort", $subr_name, "failure to execute the uname command");
9291 my $kernel_name = qx ($target_cmd -s
); chomp ($kernel_name);
9292 my $nodename = qx ($target_cmd -n
); chomp ($nodename);
9293 my $kernel_release = qx ($target_cmd -r
); chomp ($kernel_release);
9294 my $kernel_version = qx ($target_cmd -v
); chomp ($kernel_version);
9295 my $machine = qx ($target_cmd -m
); chomp ($machine);
9296 my $processor = qx ($target_cmd -p
); chomp ($processor);
9297 my $hardware_platform = qx ($target_cmd -i
); chomp ($hardware_platform);
9298 my $operating_system = qx ($target_cmd -o
); chomp ($operating_system);
9300 $local_system_config{"kernel_name"} = $kernel_name;
9301 $local_system_config{"nodename"} = $nodename;
9302 $local_system_config{"kernel_release"} = $kernel_release;
9303 $local_system_config{"kernel_version"} = $kernel_version;
9304 $local_system_config{"machine"} = $machine;
9305 $local_system_config{"processor"} = $processor;
9306 $local_system_config{"hardware_platform"} = $hardware_platform;
9307 $local_system_config{"operating_system"} = $operating_system;
9309 gp_message
("debug", $subr_name, "the output from the $target_cmd command is split into the following variables:");
9310 gp_message
("debug", $subr_name, "kernel_name = $kernel_name");
9311 gp_message
("debug", $subr_name, "nodename = $nodename");
9312 gp_message
("debug", $subr_name, "kernel_release = $kernel_release");
9313 gp_message
("debug", $subr_name, "kernel_version = $kernel_version");
9314 gp_message
("debug", $subr_name, "machine = $machine");
9315 gp_message
("debug", $subr_name, "processor = $processor");
9316 gp_message
("debug", $subr_name, "hardware_platform = $hardware_platform");
9317 gp_message
("debug", $subr_name, "operating_system = $operating_system");
9319 #------------------------------------------------------------------------------
9320 # Check if the system we are running on is supported.
9321 #------------------------------------------------------------------------------
9322 my $is_supported = ${ check_support_for_processor
(\
$machine) };
9324 if (not $is_supported)
9326 $msg = "the $machine instruction set architecture is not supported";
9327 gp_message
("error", $subr_name, $msg);
9328 gp_message
("diag", $subr_name, "Error: " . $msg);
9330 $msg = "temporarily ignored for development purposes";
9331 gp_message
("error", $subr_name, $msg);
9333 $g_total_error_count++;
9336 #------------------------------------------------------------------------------
9337 # The current hostname is used to compare against the hostname(s) found in the
9338 # experiment directories.
9339 #------------------------------------------------------------------------------
9340 $target_cmd = $g_mapped_cmds{hostname
};
9341 $hostname_current = qx ($target_cmd); chomp ($hostname_current);
9342 $error_code = ${^CHILD_ERROR_NATIVE
};
9344 if ($error_code == 0)
9346 $local_system_config{"hostname_current"} = $hostname_current;
9349 #------------------------------------------------------------------------------
9350 # This is unlikely to happen, but you never know.
9351 #------------------------------------------------------------------------------
9353 gp_message
("abort", $subr_name, "failure to execute the hostname command");
9355 for my $key (sort keys %local_system_config)
9357 gp_message
("debug", $subr_name, "local_system_config{$key} = $local_system_config{$key}");
9362 } #-- End of subroutine get_system_config_info
9364 #------------------------------------------------------------------------------
9365 # This subroutine prints a message. Several types of messages are supported.
9366 # In case the type is "abort", or "error", execution is terminated.
9368 # Note that "debug", "warning", and "error" mode, the name of the calling
9369 # subroutine is truncated to 30 characters. In case the name is longer,
9370 # a warning message # is issued so you know this has happened.
9372 # Note that we use lcfirst () and ucfirst () to enforce whether the first
9373 # character is printed in lower or uppercase. It is nothing else than a
9374 # convenience, but creates more consistency across messages.
9375 #------------------------------------------------------------------------------
9378 my $subr_name = get_my_name
();
9380 my ($action, $caller_name, $comment_line) = @_;
9382 #------------------------------------------------------------------------------
9383 # The debugXL identifier is special. It is accepted, but otherwise ignored.
9384 # This allows to (temporarily) disable debug print statements, but keep them
9386 #------------------------------------------------------------------------------
9387 my %supported_identifiers = (
9388 "verbose" => "[Verbose]",
9389 "debug" => "[Debug]",
9390 "error" => "[Error]",
9391 "warning" => "[Warning]",
9392 "abort" => "[Abort]",
9393 "assertion" => "[Assertion error]",
9399 my $fixed_size_name;
9401 my $string_limit = 30;
9402 my $strlen = length ($caller_name);
9403 my $trigger_debug = $FALSE;
9407 if ($action =~ /debug\s*(.+)/)
9411 my $orig_value = $1;
9412 $debug_size = lc ($1);
9414 if ($debug_size =~ /^s$|^m$|^l$|^xl$/)
9416 if ($g_debug_size{$debug_size})
9418 #------------------------------------------------------------------------------
9419 # All we need to know is whether a debug action is requested and whether the
9420 # size has been enabled. By setting $action to "debug", the code below is
9421 # simplified. Note that only using $trigger_debug below is actually sufficient.
9422 #------------------------------------------------------------------------------
9423 $trigger_debug = $TRUE;
9428 die "$subr_name: debug size $orig_value is not supported";
9433 elsif ($action eq "debug")
9435 $trigger_debug = $TRUE;
9438 #------------------------------------------------------------------------------
9439 # Catch any non-supported identifier.
9440 #------------------------------------------------------------------------------
9441 if (defined ($supported_identifiers{$action}))
9443 $identifier = $supported_identifiers{$action};
9447 die ("$subr_name - input error: $action is not supported");
9449 if (($action eq "debug") and (not $g_debug))
9451 $trigger_debug = $FALSE;
9454 #------------------------------------------------------------------------------
9455 # Unconditionally buffer all warning messages. These are available through the
9456 # index.html page and cannot be disabled.
9458 # If the quiet mode has been enabled, warnings are not printed though.
9459 #------------------------------------------------------------------------------
9460 if ($action eq "warning")
9462 #------------------------------------------------------------------------------
9463 # Remove any leading <br>, capitalize the first letter, and put the <br> back
9464 # before storing the message in the buffer.
9465 #------------------------------------------------------------------------------
9466 if ($comment_line =~ /^$g_html_new_line/)
9468 $msg = $comment_line;
9469 $msg =~ s/$g_html_new_line//;
9470 $comment_line = $g_html_new_line . ucfirst ($msg);
9472 push (@g_warning_msgs, $comment_line);
9476 push (@g_warning_msgs, ucfirst ($comment_line));
9480 #------------------------------------------------------------------------------
9481 # Unconditionally buffer all errror messages. These will be printed prior to
9482 # terminate execution.
9483 #------------------------------------------------------------------------------
9484 if ($action eq "error")
9485 #------------------------------------------------------------------------------
9486 # Remove any leading <br>, capitalize the first letter, and put the <br> back.
9487 #------------------------------------------------------------------------------
9489 if ($comment_line =~ /^$g_html_new_line/)
9491 $msg = $comment_line;
9492 $msg =~ s/$g_html_new_line//;
9493 $comment_line = $g_html_new_line . ucfirst ($msg);
9495 push (@g_error_msgs, $comment_line);
9499 push (@g_error_msgs, ucfirst ($comment_line));
9503 #------------------------------------------------------------------------------
9504 # Quick return in several cases. Note that "debug", "verbose", "warning", and
9505 # "diag" messages are suppressed in quiet mode, but "error", "abort" and
9506 # "assertion" always pass.
9507 #------------------------------------------------------------------------------
9509 ($action eq "verbose") and (not $g_verbose))
9510 or (($action eq "debug") and (not $trigger_debug))
9511 or (($action eq "verbose") and ($g_quiet))
9512 or (($action eq "debug") and ($g_quiet))
9513 or (($action eq "warning") and ($g_quiet))
9514 or (($action eq "diag") and ($g_quiet)))
9519 #------------------------------------------------------------------------------
9520 # In diag mode, just print the input line and nothing else.
9521 #------------------------------------------------------------------------------
9524 or ($action eq "abort")
9525 or ($action eq "assertion"))
9526 ## or ($action eq "error"))
9528 #------------------------------------------------------------------------------
9529 # Construct the string to be printed. Include an identifier and the name of
9531 #------------------------------------------------------------------------------
9532 if ($strlen > $string_limit)
9534 $truncated_name = substr ($caller_name, 0, $string_limit);
9535 $fixed_size_name = sprintf ("%-"."$string_limit"."s", $truncated_name);
9536 print "Warning in $subr_name - the name of the caller is: " .
9537 $caller_name . "\n";
9538 print "Warning in $subr_name - the string length is $strlen and " .
9539 "exceeds $string_limit\n";
9543 $fixed_size_name = sprintf ("%-"."$string_limit"."s", $caller_name);
9546 ## if (($action eq "error") or ($action eq "abort"))
9547 if ($action eq "abort")
9548 #------------------------------------------------------------------------------
9549 # Enforce that the message starts with a lowercase symbol. Since these are
9550 # user errors, the name of the routine is not shown. The same for "abort".
9551 # If you want to display the routine name too, use an assertion.
9552 #------------------------------------------------------------------------------
9554 my $error_identifier = $supported_identifiers{"error"};
9557 $ignore_value = print_errors_buffer
(\
$error_identifier);
9559 printf ("%-9s %s", $identifier, ucfirst ($comment_line));
9560 printf (" - %s\n", "execution is terminated");
9562 elsif ($action eq "assertion")
9563 #------------------------------------------------------------------------------
9564 # Enforce that the message starts with a lowercase symbol.
9565 #------------------------------------------------------------------------------
9567 #------------------------------------------------------------------------------
9568 # The lines are too long, but breaking the argument list gives this warning:
9569 # printf (...) interpreted as function
9570 #------------------------------------------------------------------------------
9571 printf ("%-17s %-30s", $identifier, $fixed_size_name);
9572 printf (" - %s\n", $comment_line);
9574 elsif (($action eq "debug") and ($trigger_debug))
9575 #------------------------------------------------------------------------------
9576 # Debug messages are printed "as is". Avoids issues when searching for them ;-)
9577 #------------------------------------------------------------------------------
9579 printf ("%-9s %-30s", $identifier, $fixed_size_name);
9580 printf (" - %s\n", $comment_line);
9583 #------------------------------------------------------------------------------
9584 # Enforce that the message starts with a lowercase symbol.
9585 #------------------------------------------------------------------------------
9587 printf ("%-9s %-30s", $identifier, $fixed_size_name);
9588 printf (" - %s\n", $comment_line);
9591 elsif ($action eq "verbose")
9592 #------------------------------------------------------------------------------
9593 # The first character in the verbose message is capatilized.
9594 #------------------------------------------------------------------------------
9596 printf ("%s\n", ucfirst ($comment_line));
9598 elsif ($action eq "diag")
9599 #------------------------------------------------------------------------------
9600 # The diag messages are meant to be diagnostics. Only the comment line is
9602 #------------------------------------------------------------------------------
9604 printf ("%s\n", $comment_line);
9608 #------------------------------------------------------------------------------
9609 # Terminate execution in case the identifier is "abort".
9610 #------------------------------------------------------------------------------
9611 if (($action eq "abort") or ($action eq "assertion"))
9613 ## print "ABORT temporarily disabled for testing purposes\n";
9621 } #-- End of subroutine gp_message
9623 #------------------------------------------------------------------------------
9624 # Create an HTML page with the warnings. If there are no warnings, include
9625 # line to this extent. The alternative is to supporess the entire page, but
9626 # that breaks the consistency in the output.
9627 #------------------------------------------------------------------------------
9628 sub html_create_warnings_page
9630 my $subr_name = get_my_name
();
9632 my ($outputdir_ref) = @_;
9634 my $outputdir = ${ $outputdir_ref };
9637 my $html_acknowledgement;
9641 my $html_home_right;
9642 my $html_title_header;
9643 my $msg_no_warnings = "There are no warning messages issued.";
9648 my $outfile = $outputdir . $g_html_base_file_name{"warnings"} . ".html";
9650 gp_message
("debug", $subr_name, "outfile = $outfile");
9652 open (WARNINGS_OUT
, ">", $outfile)
9653 or die ("unable to open $outfile for writing - '$!'");
9654 gp_message
("debug", $subr_name, "opened file $outfile for writing");
9656 gp_message
("debug", $subr_name, "building warning file $outfile");
9658 #------------------------------------------------------------------------------
9659 # Generate some of the structures used in the HTML output.
9660 #------------------------------------------------------------------------------
9661 $file_title = "Warning messages";
9662 $html_header = ${ create_html_header
(\
$file_title) };
9663 $html_home_right = ${ generate_home_link
("right") };
9665 $page_title = "Warning Messages";
9667 $position_text = "center";
9668 $html_title_header = ${ generate_a_header
(\
$page_title, \
$size_text, \
$position_text) };
9670 #------------------------------------------------------------------------------
9671 # Get the acknowledgement, return to main link, and final html statements.
9672 #------------------------------------------------------------------------------
9673 $html_home_left = ${ generate_home_link
("left") };
9674 $html_acknowledgement = ${ create_html_credits
() };
9675 $html_end = ${ terminate_html_document
() };
9677 #------------------------------------------------------------------------------
9678 # Generate the HTML file.
9679 #------------------------------------------------------------------------------
9680 print WARNINGS_OUT
$html_header;
9681 print WARNINGS_OUT
$html_home_right;
9682 print WARNINGS_OUT
$html_title_header;
9684 if ($g_total_warning_count > 0)
9686 print WARNINGS_OUT
"<pre>\n";
9687 print WARNINGS_OUT
"$_\n" for @g_warning_msgs;
9688 print WARNINGS_OUT
"</pre>\n";
9692 print WARNINGS_OUT
$msg_no_warnings;
9695 print WARNINGS_OUT
$html_home_left;
9696 print WARNINGS_OUT
"<br>\n";
9697 print WARNINGS_OUT
$html_acknowledgement;
9698 print WARNINGS_OUT
$html_end;
9700 close (WARNINGS_OUT
);
9704 } #-- End of subroutine html_create_warnings_page
9706 #------------------------------------------------------------------------------
9707 # Generate the HTML with the experiment summary.
9708 #------------------------------------------------------------------------------
9709 sub html_generate_exp_summary
9711 my $subr_name = get_my_name
();
9713 my ($outputdir_ref, $experiment_data_ref) = @_;
9715 my $outputdir = ${ $outputdir_ref };
9716 my @experiment_data = @
{ $experiment_data_ref };
9724 my $html_title_header;
9725 my $html_acknowledgement;
9727 my @html_exp_table_data = ();
9728 my $html_exp_table_data_ref;
9729 my @table_execution_stats = ();
9730 my $table_execution_stats_ref;
9732 gp_message
("debug", $subr_name, "outputdir = $outputdir");
9733 $outputdir = append_forward_slash
($outputdir);
9734 gp_message
("debug", $subr_name, "outputdir = $outputdir");
9736 $file_title = "Experiment information";
9737 $page_title = "Experiment Information";
9739 $position_text = "center";
9740 $html_header = ${ create_html_header
(\
$file_title) };
9741 $html_home = ${ generate_home_link
("right") };
9743 $html_title_header = ${ generate_a_header
(\
$page_title, \
$size_text, \
$position_text) };
9745 $outfile = $outputdir . $g_html_base_file_name{"experiment_info"} . ".html";
9746 open (EXP_INFO
, ">", $outfile)
9747 or die ("unable to open $outfile for writing - '$!'");
9748 gp_message
("debug", $subr_name, "opened file $outfile for writing");
9750 print EXP_INFO
$html_header;
9751 print EXP_INFO
$html_home;
9752 print EXP_INFO
$html_title_header;
9754 ($html_exp_table_data_ref, $table_execution_stats_ref) = html_generate_table_data
($experiment_data_ref);
9756 @html_exp_table_data = @
{ $html_exp_table_data_ref };
9757 @table_execution_stats = @
{ $table_execution_stats_ref };
9759 print EXP_INFO
"$_" for @html_exp_table_data;
9761 ## print EXP_INFO "<pre>\n";
9762 ## print EXP_INFO "$_\n" for @html_caller_callee;
9763 ## print EXP_INFO "</pre>\n";
9765 #------------------------------------------------------------------------------
9766 # Get the acknowledgement, return to main link, and final html statements.
9767 #------------------------------------------------------------------------------
9768 $html_home = ${ generate_home_link
("left") };
9769 $html_acknowledgement = ${ create_html_credits
() };
9770 $html_end = ${ terminate_html_document
() };
9772 print EXP_INFO
$html_home;
9773 print EXP_INFO
"<br>\n";
9774 print EXP_INFO
$html_acknowledgement;
9775 print EXP_INFO
$html_end;
9779 return (\
@table_execution_stats);
9781 } #-- End of subroutine html_generate_exp_summary
9783 #------------------------------------------------------------------------------
9784 # Generate the index.html file.
9785 #------------------------------------------------------------------------------
9786 sub html_generate_index
9788 my $subr_name = get_my_name
();
9790 my ($outputdir_ref, $html_first_metric_file_ref, $summary_metrics_ref,
9791 $number_of_metrics_ref, $function_info_ref, $function_address_info_ref,
9792 $sort_fields_ref, $exp_dir_list_ref, $addressobjtextm_ref,
9793 $metric_description_reversed_ref, $table_execution_stats_ref) = @_;
9795 my $outputdir = ${ $outputdir_ref };
9796 my $html_first_metric_file = ${ $html_first_metric_file_ref };
9797 my $summary_metrics = ${ $summary_metrics_ref };
9798 my $number_of_metrics = ${ $number_of_metrics_ref };
9799 my @function_info = @
{ $function_info_ref };
9800 my %function_address_info = %{ $function_address_info_ref };
9801 my @sort_fields = @
{ $sort_fields_ref };
9802 my @exp_dir_list = @
{ $exp_dir_list_ref };
9803 my %addressobjtextm = %{ $addressobjtextm_ref };
9804 my %metric_description_reversed = %{ $metric_description_reversed_ref };
9805 my @table_execution_stats = @
{ $table_execution_stats_ref };
9807 my @file_contents = ();
9809 my $acknowledgement;
9810 my @abs_path_exp_dirs = ();
9811 my $input_experiments;
9812 my $target_function;
9816 my %html_source_functions = ();
9818 my @experiment_directories = ();
9819 my $html_acknowledgement;
9820 my $html_file_title;
9821 my $html_output_file;
9822 my $html_function_view;
9823 my $html_caller_callee_view;
9824 my $html_experiment_info;
9825 my $html_warnings_page;
9830 my $max_length_metrics;
9837 my $base_index_page;
9872 #------------------------------------------------------------------------------
9873 # Add a forward slash to make it easier when creating file names.
9874 #------------------------------------------------------------------------------
9875 $outputdir = append_forward_slash
($outputdir);
9876 gp_message
("debug", $subr_name, "outputdir = $outputdir");
9878 my $LANG = $g_locale_settings{"LANG"};
9879 my $decimal_separator = $g_locale_settings{"decimal_separator"};
9881 $input_experiments = join (", ", @exp_dir_list);
9883 for my $i (0 .. $#exp_dir_list)
9885 my $dir = get_basename
($exp_dir_list[$i]);
9886 push @abs_path_exp_dirs, $dir;
9888 $input_experiments = join (", ", @abs_path_exp_dirs);
9890 gp_message
("debug", $subr_name, "input_experiments = $input_experiments");
9892 #------------------------------------------------------------------------------
9893 # TBD: Pass in the values for $expr_name and $cmd
9894 #------------------------------------------------------------------------------
9895 $html_file_title = "Main index page";
9897 @experiment_directories = split (",", $input_experiments);
9898 $html_acknowledgement = ${ create_html_credits
() };
9900 $html_end = ${ terminate_html_document
() };
9902 $html_output_file = $outputdir . $g_html_base_file_name{"index"} . ".html";
9904 open (INDEX
, ">", $html_output_file)
9905 or die ("$subr_name - unable to open file $html_output_file for writing - '$!'");
9906 gp_message
("debug", $subr_name, "opened file $html_output_file for writing");
9908 $page_title = "GPROFNG Performance Analysis";
9910 $position_text = "center";
9911 $html_gprofng = ${ generate_a_header
(\
$page_title, \
$size_text, \
$position_text) };
9913 $html_header = ${ create_html_header
(\
$html_file_title) };
9915 print INDEX
$html_header;
9916 print INDEX
$html_gprofng;
9917 print INDEX
"$_" for @g_html_experiment_stats;
9918 print INDEX
"$_" for @table_execution_stats;
9920 $html_experiment_info = "<a href=\'";
9921 $html_experiment_info .= $g_html_base_file_name{"experiment_info"} . ".html";
9922 $html_experiment_info .= "\'><h3>Experiment Details</h3></a>\n";
9924 $html_warnings_page = "<a href=\'";
9925 $html_warnings_page .= $g_html_base_file_name{"warnings"} . ".html";
9926 $html_warnings_page .= "\'><h3>Warnings (" . $g_total_warning_count;
9927 $html_warnings_page .= ")</h3></a>\n";
9929 $html_function_view = "<a href=\'";
9930 $html_function_view .= $html_first_metric_file;
9931 $html_function_view .= "\'><h3>Function View</h3></a>\n";
9933 $html_caller_callee_view = "<a href=\'";
9934 $html_caller_callee_view .= $g_html_base_file_name{"caller_callee"} . ".html";
9935 $html_caller_callee_view .= "\'><h3>Caller Callee View</h3></a>\n";
9937 print INDEX
"<br>\n";
9938 ## print INDEX "<b>\n";
9939 print INDEX
$html_experiment_info;
9940 print INDEX
$html_warnings_page;
9941 ## print INDEX "<br>\n";
9942 ## print INDEX "<br>\n";
9943 print INDEX
$html_function_view;
9944 ## print INDEX "<br>\n";
9945 ## print INDEX "<br>\n";
9946 print INDEX
$html_caller_callee_view;
9947 ## print INDEX "</b>\n";
9948 ## print INDEX "<br>\n";
9949 ## print INDEX "<br>\n";
9951 print INDEX
$html_acknowledgement;
9952 print INDEX
$html_end;
9956 gp_message
("debug", $subr_name, "closed file $html_output_file");
9960 } #-- End of subroutine html_generate_index
9962 #------------------------------------------------------------------------------
9963 # Generate the entries for the tables with the experiment info.
9964 #------------------------------------------------------------------------------
9965 sub html_generate_table_data
9967 my $subr_name = get_my_name
();
9969 my ($experiment_data_ref) = @_;
9971 my @experiment_data = ();
9972 my @html_exp_table_data = ();
9974 ## my $html_header_line;
9982 my $title_table_summary;
9983 my $html_table_title;
9985 my @experiment_table_1_def = ();
9986 my @experiment_table_2_def = ();
9987 my @experiment_table_3_def = ();
9988 my @exp_table_summary_def = ();
9989 my @experiment_table_1 = ();
9990 my @experiment_table_2 = ();
9991 my @experiment_table_3 = ();
9992 my @exp_table_summary = ();
9993 my @exp_table_selection = ();
9995 @experiment_data = @
{ $experiment_data_ref };
9997 for my $i (sort keys @experiment_data)
9999 for my $fields (sort keys %{ $experiment_data[$i] })
10001 gp_message
("debugXL", $subr_name, "$i => experiment_data[$i]{$fields} = $experiment_data[$i]{$fields}");
10005 $title_table_1 = "Target System Configuration";
10006 $title_table_2 = "Experiment Statistics";
10007 $title_table_3 = "Run Time Statistics";
10008 $title_table_summary = "Main Statistics";
10011 $position_text = "left";
10013 push @experiment_table_1_def, { name
=> "Experiment name" , key
=> "exp_name_short"};
10014 push @experiment_table_1_def, { name
=> "Hostname" , key
=> "hostname"};
10015 push @experiment_table_1_def, { name
=> "Operating system", key
=> "OS"};
10016 push @experiment_table_1_def, { name
=> "Architecture", key
=> "architecture"};
10017 push @experiment_table_1_def, { name
=> "Page size", key
=> "page_size"};
10019 push @experiment_table_2_def, { name
=> "Target command" , key
=> "target_cmd"};
10020 push @experiment_table_2_def, { name
=> "Date command executed" , key
=> "start_date"};
10021 push @experiment_table_2_def, { name
=> "Data collection duration", key
=> "data_collection_duration"};
10022 push @experiment_table_2_def, { name
=> "End time of the experiment", key
=> "end_experiment"};
10024 push @experiment_table_3_def, { name
=> "User CPU time (seconds)", key
=> "user_cpu_time"};
10025 ## push @experiment_table_3_def, { name => "User CPU time (percentage)", key => "user_cpu_percentage"};
10026 push @experiment_table_3_def, { name
=> "System CPU time (seconds)", key
=> "system_cpu_time"};
10027 ## push @experiment_table_3_def, { name => "System CPU time (percentage)", key => "system_cpu_percentage"};
10028 push @experiment_table_3_def, { name
=> "Sleep time (seconds)", key
=> "sleep_time"};
10029 ## push @experiment_table_3_def, { name => "Sleep time (percentage)", key => "sleep_percentage"};
10031 push @exp_table_summary_def, { name
=> "Experiment name" , key
=> "exp_name_short"};
10032 push @exp_table_summary_def, { name
=> "Hostname" , key
=> "hostname"};
10033 push @exp_table_summary_def, { name
=> "User CPU time (seconds)", key
=> "user_cpu_time"};
10034 push @exp_table_summary_def, { name
=> "System CPU time (seconds)", key
=> "system_cpu_time"};
10035 push @exp_table_summary_def, { name
=> "Sleep time (seconds)", key
=> "sleep_time"};
10037 $html_table_title = ${ generate_a_header
(\
$title_table_1, \
$size_text, \
$position_text) };
10039 push (@html_exp_table_data, $html_table_title);
10041 @experiment_table_1 = @
{ create_table
(\
@experiment_data, \
@experiment_table_1_def) };
10043 push (@html_exp_table_data, @experiment_table_1);
10045 $html_table_title = ${ generate_a_header
(\
$title_table_2, \
$size_text, \
$position_text) };
10047 push (@html_exp_table_data, $html_table_title);
10049 @experiment_table_2 = @
{ create_table
(\
@experiment_data, \
@experiment_table_2_def) };
10051 push (@html_exp_table_data, @experiment_table_2);
10053 $html_table_title = ${ generate_a_header
(\
$title_table_3, \
$size_text, \
$position_text) };
10055 push (@html_exp_table_data, $html_table_title);
10057 @experiment_table_3 = @
{ create_table
(\
@experiment_data, \
@experiment_table_3_def) };
10059 push (@html_exp_table_data, @experiment_table_3);
10061 $html_table_title = ${ generate_a_header
(\
$title_table_summary, \
$size_text, \
$position_text) };
10063 push (@exp_table_summary, $html_table_title);
10065 @exp_table_selection = @
{ create_table
(\
@experiment_data, \
@exp_table_summary_def) };
10067 push (@exp_table_summary, @exp_table_selection);
10069 return (\
@html_exp_table_data, \
@exp_table_summary);
10071 } #-- End of subroutine html_generate_table_data
10073 #------------------------------------------------------------------------------
10074 # Generate the HTML text to print in case a file is empty.
10075 #------------------------------------------------------------------------------
10076 sub html_text_empty_file
10078 my $subr_name = get_my_name
();
10080 my ($comment_ref, $error_file_ref) = @_;
10090 my @html_empty_file = ();
10092 $comment = ${ $comment_ref };
10093 $error_file = ${ $error_file_ref };
10095 $file_title = "File is empty";
10096 $html_header = ${ create_html_header
(\
$file_title) };
10097 $html_end = ${ terminate_html_document
() };
10098 $html_home = ${ generate_home_link
("left") };
10100 push (@html_empty_file, $html_header);
10102 $error_message = "<b>" . $comment . "</b>";
10103 $error_message = set_background_color_string
($error_message, $g_html_color_scheme{"error_message"});
10104 push (@html_empty_file, $error_message);
10106 if (not is_file_empty
($error_file))
10108 $error_message = "<p><em>Check file $error_file for more information</em></p>";
10110 push (@html_empty_file, $error_message);
10111 push (@html_empty_file, $html_home);
10112 push (@html_empty_file, "<br>");
10113 push (@html_empty_file, $g_html_credits_line);
10114 push (@html_empty_file, $html_end);
10116 return (\
@html_empty_file);
10118 } #-- End of subroutine html_text_empty_file
10120 #------------------------------------------------------------------------------
10121 # This subroutine checks if a file is empty and returns $TRUE or $FALSE.
10122 #------------------------------------------------------------------------------
10125 my $subr_name = get_my_name
();
10127 my ($filename) = @_;
10136 if (not -e
$filename)
10138 #------------------------------------------------------------------------------
10139 # The return value is used in the caller. This is why we return the empty
10140 # string in case the file does not exist.
10141 #------------------------------------------------------------------------------
10142 $msg = "filename = $filename not found";
10143 gp_message
("debug", $subr_name, $msg);
10148 $file_stat = stat ($filename);
10149 $size = $file_stat->size;
10150 $is_empty = ($size == 0) ?
$TRUE : $FALSE;
10153 $msg = "filename = $filename size = $size is_empty = $is_empty";
10154 gp_message
("debug", $subr_name, $msg);
10156 return ($is_empty);
10158 } #-- End of subroutine is_file_empty
10160 #------------------------------------------------------------------------------
10161 # Check if a file is executable and return $TRUE or $FALSE.
10162 #------------------------------------------------------------------------------
10163 sub is_file_executable
10165 my $subr_name = get_my_name
();
10167 my ($filename) = @_;
10169 my $file_permissions;
10173 my $number_of_bytes;
10174 my @permission_settings = ();
10175 my %permission_values = ();
10179 gp_message
("debug", $subr_name, "check if filename = $filename is executable");
10181 if (not -e
$filename)
10183 #------------------------------------------------------------------------------
10184 # The return value is used in the caller. This is why we return the empty
10185 # string in case the file does not exist.
10186 #------------------------------------------------------------------------------
10187 gp_message
("debug", $subr_name, "filename = $filename not found");
10188 $is_executable = $FALSE;
10192 $mode = stat ($filename)->mode;
10194 gp_message
("debugXL", $subr_name, "mode = $mode");
10195 #------------------------------------------------------------------------------
10196 # Get username. We currently do not do anything with this though and the
10197 # code is commented out.
10199 # my $my_name = getlogin () || getpwuid($<) || "Kilroy";
10200 # gp_message ("debug", $subr_name, "my_name = $my_name");
10201 #------------------------------------------------------------------------------
10203 #------------------------------------------------------------------------------
10204 # Convert file permissions to octal, split the individual numbers and store
10205 # the values for the respective users.
10206 #------------------------------------------------------------------------------
10207 $file_permissions = sprintf("%o", $mode & 07777);
10209 @permission_settings = split (//, $file_permissions);
10211 $number_of_bytes = scalar (@permission_settings);
10213 gp_message
("debugXL", $subr_name, "file_permissions = $file_permissions");
10214 gp_message
("debugXL", $subr_name, "permission_settings = @permission_settings");
10215 gp_message
("debugXL", $subr_name, "number_of_settings = $number_of_bytes");
10217 if ($number_of_bytes == 4)
10221 elsif ($number_of_bytes == 3)
10227 my $msg = "unexpected number of $number_of_bytes bytes " .
10228 "in permission settings: @permission_settings";
10229 gp_message
("assertion", $subr_name, $msg);
10232 $permission_values{user
} = $permission_settings[$index_offset++];
10233 $permission_values{group
} = $permission_settings[$index_offset++];
10234 $permission_values{other
} = $permission_settings[$index_offset];
10236 #------------------------------------------------------------------------------
10237 # The executable bit should be set for user, group and other. If this fails
10238 # we mark the file as not executable. Note that this is gprofng specific.
10239 #------------------------------------------------------------------------------
10240 $is_executable = $TRUE;
10241 for my $k (keys %permission_values)
10243 my $msg = "permission_values{" . $k . "} = " .
10244 $permission_values{$k};
10245 gp_message
("debugXL", $subr_name, $msg);
10247 if ($permission_values{$k} % 2 == 0)
10249 $is_executable = $FALSE;
10255 gp_message
("debug", $subr_name, "is_executable = $is_executable");
10257 return ($is_executable);
10259 } #-- End of subroutine is_file_executable
10261 #------------------------------------------------------------------------------
10262 # Print a message after a failure in $GP_DISPLAY_TEXT.
10263 #------------------------------------------------------------------------------
10264 sub msg_display_text_failure
10266 my $subr_name = get_my_name
();
10268 my ($gp_display_text_cmd, $error_code, $error_file) = @_;
10272 $msg = "error code = $error_code - failure executing the following command:";
10273 gp_message
("error", $subr_name, $msg);
10275 gp_message
("error", $subr_name, $gp_display_text_cmd);
10277 $msg = "check file $error_file for more details";
10278 gp_message
("error", $subr_name, $msg);
10282 } #-- End of subroutine msg_display_text_failure
10284 #------------------------------------------------------------------------------
10286 #------------------------------------------------------------------------------
10289 my $subr_name = get_my_name
();
10291 my ($metric_description_ref, $metrics, $field, $file) = @_;
10293 my %metric_description = %{ $metric_description_ref };
10295 my @splitted_metrics;
10296 my $splitted_metrics;
10303 my @reported_metrics;
10304 my $reported_metrics;
10306 my $hdr_href_regex;
10314 my $gp_metrics_file;
10315 my $gp_metrics_dir;
10316 my $suffix_not_used;
10318 my $is_calls = $FALSE;
10319 my $is_calltree = $FALSE;
10321 gp_message
("debugXL", $subr_name,"1:metrics->$metrics<- field->$field<- file->$file<-");
10323 #------------------------------------------------------------------------------
10324 # According to https://perldoc.perl.org/File::Basename, both dirname and
10325 # basename are not reliable and fileparse () is recommended instead.
10327 # Note that $gp_metrics_dir has a trailing "/".
10328 #------------------------------------------------------------------------------
10329 ($gp_metrics_file, $gp_metrics_dir, $suffix_not_used) = fileparse
($file, ".sort.func-PC");
10331 gp_message
("debugXL", $subr_name, "gp_metrics_dir = $gp_metrics_dir gp_metrics_file = $gp_metrics_file");
10332 gp_message
("debugXL", $subr_name, "suffix_not_used = $suffix_not_used");
10334 if ($gp_metrics_file eq "calls")
10338 if ($gp_metrics_file eq "calltree")
10340 $is_calltree = $TRUE;
10343 $gp_metrics_file = "gp-metrics-" . $gp_metrics_file . "-PC";
10344 $gp_metrics_file = $gp_metrics_dir . $gp_metrics_file;
10346 gp_message
("debugXL", $subr_name, "gp_metrics_file is $gp_metrics_file");
10348 open (GP_METRICS
, "<", $gp_metrics_file)
10349 or die ("$subr_name - unable to open gp_metrics file $gp_metrics_file for reading - '$!'");
10350 gp_message
("debug", $subr_name, "opened file $gp_metrics_file for reading");
10352 $new_metrics = $metrics;
10354 while (<GP_METRICS
>)
10358 gp_message
("debugXL", $subr_name, "rat = $rat - new_metrics = $new_metrics");
10359 #------------------------------------------------------------------------------
10360 # Capture the string after "Current metrics:" and if it ends with ":name",
10362 #------------------------------------------------------------------------------
10363 if ($rat =~ /^\s*Current metrics:\s*(.*)$/)
10366 if ($new_metrics =~ /^(.*):name$/)
10373 close (GP_METRICS
);
10375 if ($is_calls or $is_calltree)
10377 #------------------------------------------------------------------------------
10378 # Remove any inclusive metrics from the list.
10379 #------------------------------------------------------------------------------
10380 while ($new_metrics =~ /(.*)(i\.[^:]+)(.*)$/)
10384 gp_message
("debugXL", $subr_name, "1b: new_metrics = $new_metrics pre = $pre post = $post");
10385 if (substr ($post,0,1) eq ":")
10387 $post = substr ($post,1);
10389 $new_metrics = $pre.$post;
10393 $metrics = $new_metrics;
10395 gp_message
("debugXL", $subr_name, "2:metrics->$metrics<- field->$field<- file->$file<-");
10397 #------------------------------------------------------------------------------
10398 # Find the line starting with "address:" and strip this part away.
10399 #------------------------------------------------------------------------------
10400 if ($metrics =~ /^address:(.*)/)
10402 $reported_metrics = $1;
10403 #------------------------------------------------------------------------------
10404 # Focus on the filename ending with "-PC". When found, strip this part away.
10405 #------------------------------------------------------------------------------
10406 if ($file =~ /^(.*)-PC$/)
10409 if ($noPCfile =~ /^(.*)functions.sort.func$/)
10411 $noPCfile = $1."functions.func";
10413 push (@moo, "$reported_metrics\n");
10417 #------------------------------------------------------------------------------
10418 # Split the list into an array with the individual metrics.
10420 # TBD: This should be done only once!
10421 #------------------------------------------------------------------------------
10422 @reported_metrics = split (":", $reported_metrics);
10423 for my $i (@reported_metrics)
10425 gp_message
("debugXL", $subr_name, "reported_metrics = $i");
10428 $hdr_regex = "^\\s*";
10429 $hdr_href_regex = "^\\s*";
10430 $hdr_src_regex = "^(\\s+|<i>\\s+)";
10432 for my $m (@reported_metrics)
10435 my $description = ${ retrieve_metric_description
(\
$m, \
%metric_description) };
10436 gp_message
("debugXL", $subr_name, "m = $m description = $description");
10437 if (substr ($m,0,1) eq "e")
10439 push (@moo,"$m:$description\n");
10440 $hdr_regex .= "(Excl\\.\.*)";
10441 $hdr_href_regex .= "(<a.*>)(Excl\\.)(<\/a>)([^<]+)";
10442 $hdr_src_regex .= "(Excl\\.\.*)";
10445 if (substr ($m,0,1) eq "i")
10447 push (@moo,"$m:$description\n");
10448 $hdr_regex .= "(Incl\\.\.*)";
10449 $hdr_href_regex .= "(<a.*>)(Incl\\.)(<\/a>)([^<]+)";
10450 $hdr_src_regex .= "(Incl\\.\.*)";
10453 if (substr ($m,0,1) eq "a")
10459 $am = ${ retrieve_metric_description
(\
$a, \
%metric_description) };
10460 $am =~ s/Exclusive/Attributed/;
10461 push (@moo,"$m:$am\n");
10462 $hdr_regex .= "(Attr\\.\.*)";
10463 $hdr_href_regex .= "(<a.*>)(Attr\\.)(<\/a>)([^<]+)";
10464 $hdr_src_regex .= "(Attr\\.\.*)";next;
10468 $hdr_regex .= "(Name\.*)";
10469 $hdr_href_regex .= "(Name\.*)";
10471 @splitted_metrics = split (":","$metrics");
10472 $nf = scalar (@splitted_metrics);
10473 gp_message
("debug", $subr_name,"number of fields in $metrics -> $nf");
10475 open (ZMETRICS
, ">", "$noPCfile.metrics")
10476 or die ("Not able to open file $noPCfile.metrics for writing - '$!'");
10477 gp_message
("debug", $subr_name, "$noPCfile - opened file $noPCfile.metrics for writing");
10479 print ZMETRICS
@moo;
10482 gp_message
("debug", $subr_name, "wrote file $noPCfile.metrics");
10484 open (XREGEXP
, ">", "$noPCfile.c.regex")
10485 or die ("Not able to open file $noPCfile.c.regex for writing - '$!'");
10486 gp_message
("debug", $subr_name, "$noPCfile - opened file $noPCfile.c.regex for writing");
10488 print XREGEXP
"\# Number of metric fields\n";
10489 print XREGEXP
"$nf\n";
10490 print XREGEXP
"\# Header regex\n";
10491 print XREGEXP
"$hdr_regex\n";
10492 print XREGEXP
"\# href Header regex\n";
10493 print XREGEXP
"$hdr_href_regex\n";
10494 print XREGEXP
"\# src Header regex\n";
10495 print XREGEXP
"$hdr_src_regex\n";
10498 #---------------------------------------------------------------------------
10499 # Find the index of "field" in the metric list, plus one.
10500 #---------------------------------------------------------------------------
10501 if ( ($field eq "functions") or ($field eq "calls") or ($field eq "calltree"))
10507 for my $candidate_metric (@splitted_metrics)
10509 gp_message
("debugXL", $subr_name, "field = $field candidate_metric = $candidate_metric and mf = $mf");
10510 if ($candidate_metric eq $field)
10517 gp_message
("debugXL", $subr_name, "Final value mf = $mf");
10521 $re = "^\\s*(\\S+)"; # metric value
10527 $Xre = "^\\s*(\\S+)";
10536 $re .= "\\s+(\\S+)"; # metric value
10544 $Xre .= "\\s+(\\S+)";
10550 if ($field eq "calltree")
10552 $re .= "\\s+.*\\+-(.*)"; # name
10553 $Xre .= "\\s+.*\\+-(.*)\$"; # name (Right?)
10557 $re .= "\\s+(.*)"; # name
10558 $Xre .= "\\s+(.*)\$"; # name
10561 print XREGEXP
"\# Metrics and Name regex\n";
10562 print XREGEXP
"$Xre\n";
10565 gp_message
("debug", $subr_name, "wrote file $noPCfile.c.regex");
10566 gp_message
("debugXL", $subr_name, "on return Xre = $Xre");
10567 gp_message
("debugXL", $subr_name, "on return re = $re");
10571 } #-- End of subroutine name_regex
10573 #------------------------------------------------------------------------------
10575 #------------------------------------------------------------------------------
10578 my $subr_name = get_my_name
();
10580 my ($input_string) = @_;
10582 my $directory_name = append_forward_slash
($input_string);
10583 my $LANG = $g_locale_settings{"LANG"};
10584 my $result_file = $directory_name."no_source.html";
10586 gp_message
("debug", $subr_name, "result_file = $result_file");
10588 open (NS
, ">", $result_file)
10589 or die ("$subr_name: cannot open file $result_file for writing - '$!'");
10591 print NS
"<!doctype html public \"-//w3c//dtd html 3.2//en\">\n<html lang=\"$LANG\">\n<head>\n".
10592 "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" .
10593 "<title>No source</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."><pre>\n";
10594 print NS
"<a name=\"line1\"></a><font color=#C80707>"."No source was found"."</font>\n"; # red font
10595 print NS
"</pre>\n<pre>Output generated by $version_info</pre>\n";
10596 print NS
"</body></html>\n";
10602 } #-- End of subroutine nosrc
10604 #------------------------------------------------------------------------------
10606 #------------------------------------------------------------------------------
10612 if ($a =~ /^([^\d]*)(\d+)/)
10615 if ($b=~ /^([^\d]*)(\d+)/)
10618 $f1 == $f2 ?
0 : ($f1 < $f2 ?
-1 : +1);
10623 return ($a <=> $b);
10625 } #-- End of subroutine numerically
10627 #------------------------------------------------------------------------------
10628 # Parse the user options. Also perform a basic check. More checks and also
10629 # some more specific to the option, plus cross option checks, will be
10630 # performed soon after this subroutine has executed.
10632 # Warnings, but also errors, are buffered. In this way we can collect as many
10633 # warnings and errors as possible, before bailing out in case of an error.
10634 #------------------------------------------------------------------------------
10635 sub parse_and_check_user_options
10637 my $subr_name = get_my_name
();
10642 my $calltree_value;
10644 my $default_metrics_value;
10645 my $func_limit_value;
10646 my $found_exp_dir = $FALSE;
10647 my $ignore_metrics_value;
10650 my $outputdir_value;
10656 my $number_of_fields;
10658 my $internal_option_name;
10661 my $verbose = undef;
10662 my $warning = undef;
10664 my @opt_debug = ();
10665 my @opt_highlight_percentage = ();
10666 my @opt_nowarnings = ();
10667 my @opt_obsoleted_hp = ();
10668 my @opt_output = ();
10669 my @opt_overwrite = ();
10670 my @opt_quiet = ();
10671 my @opt_verbose = ();
10672 my @opt_warnings = ();
10674 #------------------------------------------------------------------------------
10675 #------------------------------------------------------------------------------
10676 my $no_of_warnings;
10677 my $total_warning_msgs = 0;
10679 my $option_warnings;
10680 my $no_of_warnings_ref;
10681 my $no_of_errors_ref;
10685 my $trigger = $FALSE;
10686 my $found_non_exp = $FALSE;
10687 my $name_non_exp_dir;
10688 my $no_of_experiments = 0;
10691 my @opt_version = ();
10692 my $stop_execution = $FALSE;
10694 my $option_value_ref;
10695 my $max_occurrences;
10696 #------------------------------------------------------------------------------
10697 # Configure Getopt to:
10698 # - Silence warnings, since these are handled by the code.
10699 # - Enforce case sensitivity in order to support -o and -O for example.
10700 #------------------------------------------------------------------------------
10701 Getopt
::Long
::Configure
("pass_through", "no_ignore_case");
10703 #------------------------------------------------------------------------------
10704 # Check for the --help and --version options. Print a message and exit.
10705 # Note that we support using both options simultaneously on the command line.
10706 #------------------------------------------------------------------------------
10708 "help" => \
@opt_help,
10709 "version" => \
@opt_version
10714 $stop_execution = $TRUE;
10715 $ignore_value = print_help_info
();
10719 $stop_execution = $TRUE;
10720 $ignore_value = print_version_info
();
10723 if ($stop_execution)
10728 #------------------------------------------------------------------------------
10729 # First, scan ARGV for the experiment names. If there are no names, or the
10730 # list with the names is not contiguous (meaning there is an non-experiment
10731 # name in this list), an error message is printed and execution is terminated.
10733 # Upon return from this function, the list with the experiment names is
10734 # known and has been removed from ARGV.
10736 # As a result, exp_dir_list is available from there on.
10738 # This makes the subsequent processing of ARGV with GetOptions() easier.
10739 #------------------------------------------------------------------------------
10740 @exp_dir_list = @
{ check_the_experiment_list
() };
10742 #------------------------------------------------------------------------------
10743 # Configure Getopt to:
10744 # - Silence warnings, since these are handled by the code.
10745 # - Enforce case sensitivity in order to support -o and -O for example.
10746 # - Allow unique abbreviations (also the default).
10747 #------------------------------------------------------------------------------
10748 Getopt
::Long
::Configure
("pass_through", "no_ignore_case", "auto_abbrev");
10749 #------------------------------------------------------------------------------
10750 # Get the remaining command line options.
10753 # = => option requires a value
10754 # : => option value is optional
10755 #------------------------------------------------------------------------------
10757 #------------------------------------------------------------------------------
10758 # All options are considered to be a string.
10760 # We request every option supported to have an optional value. Otherwise,
10761 # GetOptions skips an option that does not have a value.
10763 # The logic that parses the options deals with this and checks if an option
10764 # that should have a value, actually has one.
10765 #------------------------------------------------------------------------------
10767 "verbose|v:s" => \
@opt_verbose,
10768 "debug|d:s" => \
@opt_debug,
10769 "warnings|w:s" => \
@opt_warnings,
10770 "nowarnings:s" => \
@opt_nowarnings,
10771 "quiet|q:s" => \
@opt_quiet,
10772 "output|o=s" => \
@opt_output,
10773 "overwrite|O=s" => \
@opt_overwrite,
10774 "highlight-percentage=s" => \
@opt_highlight_percentage,
10775 "hp=s" => \
@opt_obsoleted_hp
10778 #------------------------------------------------------------------------------
10779 #------------------------------------------------------------------------------
10780 # Handle the user input and where needed, generate warnings. In a later stage
10781 # we check for (cross option) errors and warnings.
10782 #------------------------------------------------------------------------------
10783 #------------------------------------------------------------------------------
10785 #------------------------------------------------------------------------------
10786 # The very first thing to do is to determine if the user has enabled one of the
10787 # following options and take action accordingly:
10788 # --quiet, --verbose, --debug, --warnings
10790 # We first need to check for quiet mode to be set. If so, all messages need to
10791 # be silenced, regardless of the settings for verbose, debug, and warnings.
10792 #------------------------------------------------------------------------------
10794 #------------------------------------------------------------------------------
10795 # The quiet option.
10796 #------------------------------------------------------------------------------
10799 $max_occurrences = 1;
10800 $internal_option_name = "quiet";
10801 $option_name = "--quiet";
10803 my ($valid_ref) = extract_option_value
(\
@opt_quiet,
10805 \
$internal_option_name,
10808 $valid = ${ $valid_ref };
10812 $g_quiet = $g_user_settings{"quiet"}{"current_value"} eq "on" ?
10817 #------------------------------------------------------------------------------
10818 # The debug option.
10819 #------------------------------------------------------------------------------
10822 $max_occurrences = 1;
10823 $internal_option_name = "debug";
10824 $option_name = "-d/--debug";
10826 my ($valid_ref) = extract_option_value
(\
@opt_debug,
10828 \
$internal_option_name,
10831 $valid = ${ $valid_ref };
10834 #------------------------------------------------------------------------------
10835 # Set the appropriate debug size (e.g. "XL") in a table that is used in the
10836 # gp_message() subroutine.
10837 #------------------------------------------------------------------------------
10840 $ignore_value = set_debug_size
();
10844 #------------------------------------------------------------------------------
10845 # The verbose option.
10846 #------------------------------------------------------------------------------
10849 $max_occurrences = 1;
10850 $internal_option_name = "verbose";
10851 $option_name = "--verbose";
10853 my ($valid_ref) = extract_option_value
(\
@opt_verbose,
10855 \
$internal_option_name,
10857 $valid = ${ $valid_ref };
10861 $g_verbose = $g_user_settings{"verbose"}{"current_value"} eq "on" ?
10866 #------------------------------------------------------------------------------
10867 # The nowarnings option.
10868 #------------------------------------------------------------------------------
10869 if (@opt_nowarnings)
10871 $max_occurrences = 1;
10872 $internal_option_name = "nowarnings";
10873 $option_name = "--nowarnings";
10875 my ($valid_ref) = extract_option_value
(\
@opt_nowarnings,
10877 \
$internal_option_name,
10880 $valid = ${ $valid_ref };
10885 $g_user_settings{"nowarnings"}{"current_value"} eq "on" ?
10890 #------------------------------------------------------------------------------
10891 # The warnings option (deprecated).
10892 #------------------------------------------------------------------------------
10895 $max_occurrences = 1;
10896 $internal_option_name = "warnings";
10897 $option_name = "--warnings";
10899 my ($valid_ref) = extract_option_value
(\
@opt_warnings,
10901 \
$internal_option_name,
10905 #------------------------------------------------------------------------------
10906 # At this point, the debug, verbose, warnings and quiet settings are known.
10907 # This subroutine makes the final decision on these settings. For example, if
10908 # quiet mode has been specified, the settings for debug, verbose and warnings
10910 #------------------------------------------------------------------------------
10911 $ignore_value = finalize_special_options
();
10913 #------------------------------------------------------------------------------
10914 # A this point we know we can start printing messages in case verbose and/or
10915 # debug mode have been set.
10916 #------------------------------------------------------------------------------
10917 $msg = "the original command line options: " . join (", ", @CopyOfARGV);
10918 gp_message
("debug", $subr_name, $msg);
10920 $msg = "the command line options after the special options: " .
10921 join (", ", @ARGV);
10922 gp_message
("debug", $subr_name, $msg);
10924 gp_message
("verbose", $subr_name, "Parsing the user options");
10926 #------------------------------------------------------------------------------
10927 # The output option.
10928 #------------------------------------------------------------------------------
10931 $max_occurrences = 1;
10932 $internal_option_name = "output";
10933 $option_name = "-o/--output";
10935 my ($valid_ref) = extract_option_value
(\
@opt_output,
10937 \
$internal_option_name,
10941 #------------------------------------------------------------------------------
10942 # The overwrite option.
10943 #------------------------------------------------------------------------------
10944 if (@opt_overwrite)
10946 $max_occurrences = 1;
10947 $internal_option_name = "overwrite";
10948 $option_name = "-O/--overwrite";
10950 my ($valid_ref) = extract_option_value
(\
@opt_overwrite,
10952 \
$internal_option_name,
10956 #------------------------------------------------------------------------------
10957 # The highlight-percentage option.
10958 #------------------------------------------------------------------------------
10959 if (@opt_highlight_percentage)
10961 $max_occurrences = 1;
10962 $internal_option_name = "highlight_percentage";
10963 $option_name = "--highlight-percentage";
10965 my ($valid_ref) = extract_option_value
(\
@opt_highlight_percentage,
10967 \
$internal_option_name,
10971 #------------------------------------------------------------------------------
10972 # The hp option (deprecated)
10973 #------------------------------------------------------------------------------
10974 if (@opt_obsoleted_hp)
10976 $max_occurrences = 1;
10977 $internal_option_name = "hp";
10978 $option_name = "-hp";
10980 my ($valid_ref) = extract_option_value
(\
@opt_obsoleted_hp,
10982 \
$internal_option_name,
10986 #------------------------------------------------------------------------------
10987 # By now, all options given on the command line have been processed and the
10988 # list with experiment directories is known.
10990 # Process the remainder of ARGV, but other than the option generated by the
10991 # driver, ARGV should be empty.
10992 #------------------------------------------------------------------------------
10993 $ignore_value = wrap_up_user_options
();
10995 # Temporarily disabled elsif (($arg eq "-fl") or ($arg eq "--func-limit"))
10996 # Temporarily disabled elsif (($arg eq "-ct") or ($arg eq "--calltree"))
10997 # Temporarily disabled elsif (($arg eq "-tp") or ($arg eq "--threshold-percentage"))
10998 # Temporarily disabled elsif (($arg eq "-dm") or ($arg eq "--default-metrics"))
10999 # Temporarily disabled elsif (($arg eq "-im") or ($arg eq "--ignore-metrics"))
11002 #------------------------------------------------------------------------------
11003 # Print the list of the experiment directories found.
11005 # Note that later we also check for these directories to actually exist
11006 # and be valid experiments..
11007 #------------------------------------------------------------------------------
11009 $found_exp_dir = $TRUE;
11010 $msg = "the following experiment directories will be used:";
11011 gp_message
("debug", $subr_name, $msg);
11012 for my $i (keys @exp_dir_list)
11014 my $msg = "exp_dir_list[$i] = $exp_dir_list[$i]";
11015 gp_message
("debug", $subr_name, $msg);
11019 #------------------------------------------------------------------------------
11020 # Print a message if the experiment list is not valid, or empty. There will
11021 # also be error messages in the buffer. These will be printed later.
11022 #------------------------------------------------------------------------------
11024 $msg = "experiment directory name(s) are either not valid, or missing";
11025 gp_message
("debug", $subr_name, $msg);
11028 return (\
$found_exp_dir, \
@exp_dir_list);
11030 } #-- End of subroutine parse_and_check_user_options
11032 #------------------------------------------------------------------------------
11033 # Parse the generated .dis files
11034 #------------------------------------------------------------------------------
11035 sub parse_dis_files
11037 my $subr_name = get_my_name
();
11039 my ($number_of_metrics_ref, $function_info_ref,
11040 $function_address_and_index_ref, $input_string_ref,
11041 $addressobj_index_ref) = @_;
11043 #------------------------------------------------------------------------------
11044 # Note that $function_address_and_index_ref is not used, but we need to pass
11045 # in the address into generate_dis_html.
11046 #------------------------------------------------------------------------------
11047 my $number_of_metrics = ${ $number_of_metrics_ref };
11048 my @function_info = @
{ $function_info_ref };
11049 my $input_string = ${ $input_string_ref };
11050 my %addressobj_index = %{ $addressobj_index_ref };
11052 #------------------------------------------------------------------------------
11053 # The regex section.
11054 #------------------------------------------------------------------------------
11055 my $dis_filename_id_regex = 'file\.([0-9]+)\.dis';
11059 my $outputdir = append_forward_slash
($input_string);
11061 my @source_line = ();
11062 my $source_line_ref;
11067 my $target_function;
11069 gp_message
("debug", $subr_name, "building disassembly files");
11070 gp_message
("debug", $subr_name, "outputdir = $outputdir");
11072 while (glob ($outputdir.'*.dis'))
11074 gp_message
("debug", $subr_name, "processing disassembly file: $_");
11076 my $base_name = get_basename
($_);
11078 if ($base_name =~ /$dis_filename_id_regex/)
11082 gp_message
("debug", $subr_name, "processing disassembly file: $base_name $1");
11083 if (exists ($function_info[$1]{"routine"}))
11085 $target_function = $function_info[$1]{"routine"};
11086 gp_message
("debug", $subr_name, "processing disassembly file: $base_name target_function = $target_function");
11088 if (exists ($g_function_tag_id{$target_function}))
11090 gp_message
("debug", $subr_name, "target_function = $target_function ftag = $g_function_tag_id{$target_function}");
11094 my $msg = "no function tag found for $target_function";
11095 gp_message
("assertion", $subr_name, $msg);
11100 gp_message
("debug", $subr_name, "processing disassembly file: $base_name unknown id");
11105 gp_message
("verbose", $subr_name, " Processing disassembly file $filename");
11106 ($source_line_ref, $metric_ref) = generate_dis_html
(
11108 \
$number_of_metrics,
11109 $function_info_ref,
11110 $function_address_and_index_ref,
11115 \
%addressobj_index);
11117 @source_line = @
{ $source_line_ref };
11119 #------------------------------------------------------------------------------
11120 # TBD. This part needs work. The return variables from generate_dis_html ()
11121 # are not used, so the code below is meaningless, but awaiting a true fix,
11122 # the problem which appears on aarch64 is bypassed.
11123 #------------------------------------------------------------------------------
11124 if (defined ($metric_ref))
11126 @metric = @
{ $metric_ref };
11130 $msg = "metric_ref after generate_dis_html is undefined";
11131 gp_message
("debug", $subr_name, $msg);
11137 } #-- End of subroutine parse_dis_files
11139 #------------------------------------------------------------------------------
11140 # Parse the .src.txt files
11141 #------------------------------------------------------------------------------
11142 sub parse_source_files
11144 my $subr_name = get_my_name
();
11146 my ($number_of_metrics_ref, $function_info_ref, $outputdir_ref) = @_;
11148 my $number_of_metrics = ${ $number_of_metrics_ref };
11149 my $outputdir = ${ $outputdir_ref };
11152 my $outputdir_with_slash = append_forward_slash
($outputdir);
11154 gp_message
("verbose", $subr_name, "building source files");
11156 while (glob ($outputdir_with_slash.'*.src.txt'))
11158 gp_message
("verbose", $subr_name, " Processing source file: $_");
11159 gp_message
("debug", $subr_name, "processing source file: $_");
11161 my $found_target = process_source
(
11162 $number_of_metrics,
11163 $function_info_ref,
11164 $outputdir_with_slash,
11167 if (not $found_target)
11169 gp_message
("debug", $subr_name, "target function not found");
11173 } #-- End of subroutine parse_source_files
11175 #------------------------------------------------------------------------------
11176 # Routine to prepend \\ to selected symbols.
11177 #------------------------------------------------------------------------------
11178 sub prepend_backslashes
11180 my $subr_name = get_my_name
();
11182 my ($target_string) = @_;
11184 gp_message
("debug", $subr_name, "target_string on entry = $target_string");
11186 $target_string =~ s/\(/\\\(/g;
11187 $target_string =~ s/\)/\\\)/g;
11188 $target_string =~ s/\+/\\\+/g;
11189 $target_string =~ s/\[/\\\[/g;
11190 $target_string =~ s/\]/\\\]/g;
11191 $target_string =~ s/\*/\\\*/g;
11192 $target_string =~ s/\./\\\./g;
11193 $target_string =~ s/\$/\\\$/g;
11194 $target_string =~ s/\^/\\\^/g;
11195 $target_string =~ s/\#/\\\#/g;
11197 gp_message
("debug", $subr_name, "target_string on return = $target_string");
11199 return ($target_string);
11201 } #-- End of subroutine prepend_backslashes
11203 #------------------------------------------------------------------------------
11205 #------------------------------------------------------------------------------
11206 sub preprocess_function_files
11208 my $subr_name = get_my_name
();
11210 my ($metric_description_ref, $script_pc_metrics, $input_string, $sort_fields_ref) = @_;
11212 my $outputdir = append_forward_slash
($input_string);
11213 my @sort_fields = @
{ $sort_fields_ref };
11219 # TBD $outputdir .= "/";
11221 gp_message
("debug", $subr_name, "enter subroutine");
11223 my %metric_description = %{ $metric_description_ref };
11225 for my $m (keys %metric_description)
11227 gp_message
("debug", $subr_name, "metric_description{$m} = $metric_description{$m}");
11230 $re = name_regex
($metric_description_ref, $script_pc_metrics, "functions", $outputdir."functions.sort.func-PC");
11231 ($error_code, $cmd_output) = execute_system_cmd
("echo '$re' > $outputdir"."functions.sort.func-PC.name-regex");
11232 if ($error_code != 0 )
11234 gp_message
("abort", $subr_name, "execution terminated");
11237 for my $field (@sort_fields)
11239 $re = name_regex
($metric_description_ref, $script_pc_metrics, $field, $outputdir."$field.sort.func-PC");
11240 ($error_code, $cmd_output) = execute_system_cmd
("echo '$re' > $outputdir"."$field.sort.func-PC.name-regex");
11241 if ($error_code != 0 )
11243 gp_message
("abort", $subr_name, "execution terminated");
11247 $re = name_regex
($metric_description_ref, $script_pc_metrics, "calls", $outputdir."calls.sort.func-PC");
11248 ($error_code, $cmd_output) = execute_system_cmd
("echo '$re' > $outputdir"."calls.sort.func-PC.name-regex");
11249 if ($error_code != 0 )
11251 gp_message
("abort", $subr_name, "execution terminated");
11254 if ($g_user_settings{"calltree"}{"current_value"} eq "on")
11256 $re = name_regex
($metric_description_ref, $script_pc_metrics, "calltree", $outputdir."calltree.sort.func-PC");
11257 ($error_code, $cmd_output) = execute_system_cmd
("echo '$re' > $outputdir"."calltree.sort.func-PC.name-regex");
11258 if ($error_code != 0 )
11260 gp_message
("abort", $subr_name, "execution terminated");
11266 } #-- End of subroutine preprocess_function_files
11268 #------------------------------------------------------------------------------
11269 # Print the original list with the command line options.
11270 #------------------------------------------------------------------------------
11271 sub print_command_line_options
11273 my ($identifier_ref) = @_;
11275 my $identifier = ${ $identifier_ref };
11278 $msg = "The command line options (shown for ease of reference): ";
11279 printf ("%-9s %s\n", $identifier, ucfirst ($msg));
11281 $msg = join (", ", @CopyOfARGV);
11282 printf ("%-9s %s\n", $identifier, $msg);
11284 # printf ("%-9s\n", $identifier);
11288 } #-- End of subroutine print_command_line_options
11290 #------------------------------------------------------------------------------
11291 # Print all the errors messages in the buffer.
11292 #------------------------------------------------------------------------------
11293 sub print_errors_buffer
11295 my $subr_name = get_my_name
();
11297 my ($identifier_ref) = @_;
11301 my $plural_or_single;
11302 my $identifier = ${ $identifier_ref };
11304 $plural_or_single = ($g_total_error_count > 1) ?
"errors have" : "error has";
11306 if (@g_warning_msgs and $g_warnings)
11307 #------------------------------------------------------------------------------
11308 # Make sure that all warnings are printed in case of an error. This is to
11309 # avoid that warnings get lost in case the program terminates early.
11310 #------------------------------------------------------------------------------
11312 $ignore_value = print_warnings_buffer
();
11315 if (not $g_options_printed)
11316 #------------------------------------------------------------------------------
11317 # The options are printed as part of the warnings, so only if the warnings are
11318 # not printed, we need to print them in case of errors.
11319 #------------------------------------------------------------------------------
11321 $g_options_printed = $TRUE;
11322 $ignore_value = print_command_line_options
(\
$identifier);
11325 $msg = "a total of " . $g_total_error_count;
11326 $msg .= " fatal " . $plural_or_single . " been detected:";
11327 printf ("%-9s %s\n", $identifier, ucfirst ($msg));
11329 for my $key (keys @g_error_msgs)
11331 $msg = $g_error_msgs[$key];
11332 printf ("%-11s %s\n", $identifier, ucfirst ($msg));
11337 } #-- End of subroutine print_errors_buffer
11339 #------------------------------------------------------------------------------
11340 # Print the help overview
11341 #------------------------------------------------------------------------------
11342 sub print_help_info
11347 "Usage: $driver_cmd [OPTION(S)] EXPERIMENT(S)");
11350 "Process one or more experiments to generate a directory containing the");
11352 "index.html file that may be used to browse the experiment data.");
11357 #-------Marker line - do not go beyond this line ----------------------------
11358 print_help_line
("--help",
11359 "Print usage information and exit.");
11361 #-------Marker line - do not go beyond this line ----------------------------
11362 print_help_line
("--version",
11363 "Print the version number and exit.");
11365 #-------Marker line - do not go beyond this line ----------------------------
11366 print_help_line
("--verbose",
11367 "Enable verbose mode to show diagnostic messages about the");
11368 print_help_line
("",
11369 "processing of the data. By default verbose mode is disabled.");
11371 #-------Marker line - do not go beyond this line ----------------------------
11372 print_help_line
("-d [<db-vol-size>], --debug[=<db-vol-size>]",
11373 "Control the printing of run time debug information to assist with");
11374 print_help_line
("",
11375 "the troubleshooting, or further development of this tool.");
11376 print_help_line
("",
11377 "The <db-vol-size> parameter controls the output volume and is");
11378 print_help_line
("",
11379 "one from the list {s | S | m | M | l | L | xl | XL}.");
11380 print_help_line
("",
11381 "If db-vol-size is not specified, a modest amount of information");
11382 print_help_line
("",
11383 "is printed. This is equivalent to select size s, or S. The");
11384 print_help_line
("",
11385 "volume of data goes up as the size increases. Note that");
11386 print_help_line
("",
11387 "currently l/L is equivalent to xl/XL, but this is expected to");
11388 print_help_line
("",
11389 "change in future updates. By default debug mode is disabled.");
11391 #-------Marker line - do not go beyond this line ----------------------------
11392 print_help_line
("--highlight-percentage=<value>",
11393 "A percentage value in the interval [0,100] to select and color");
11394 print_help_line
("",
11395 "code source lines, as well as instructions, that are within this");
11396 print_help_line
("",
11397 "percentage of the maximum metric value(s). A value of zero");
11398 print_help_line
("",
11399 "disables this feature. The default value is 90 (%).");
11401 #-------Marker line - do not go beyond this line ----------------------------
11402 print_help_line
("-o <dirname>, --output=<dirname>",
11403 "Use <dirname> as the directory name to store the results in.");
11404 print_help_line
("",
11405 "In absence of this option, the default name is display.<n>.html.");
11406 print_help_line
("",
11407 "This directory is created in the current directory. The number");
11408 print_help_line
("",
11409 "<n> is the first positive integer number not in use in this");
11410 print_help_line
("",
11411 "naming scheme. An existing directory with the same name is not");
11412 print_help_line
("",
11413 "overwritten. Make sure that umask is set to the correct access");
11414 print_help_line
("",
11417 #-------Marker line - do not go beyond this line --------------------------
11418 print_help_line
("-O <dirname>, --overwrite=<dirname>",
11419 "Use <dirname> as the directory name to store the results in.");
11420 print_help_line
("",
11421 "In absence of this option, the default name is display.<n>.html.");
11422 print_help_line
("",
11423 "This directory is created in the current directory. The number");
11424 print_help_line
("",
11425 "<n> is the first positive integer number not in use in this");
11426 print_help_line
("",
11427 "naming scheme. An existing directory with the same name is");
11428 print_help_line
("",
11429 "silently overwritten. Make sure that umask is set to the");
11430 print_help_line
("",
11431 "correct access permissions.");
11433 #-------Marker line - do not go beyond this line --------------------------
11434 print_help_line
("-q, --quiet",
11435 "Disable the display of all warning, debug, verbose and any");
11436 print_help_line
("",
11437 "other messages. If enabled, the settings for verbose and debug");
11438 print_help_line
("",
11439 "are accepted, but ignored. With this option, there is no screen");
11440 print_help_line
("",
11441 "output, other than errors. By default quiet mode is disabled");
11443 #-------Marker line - do not go beyond this line --------------------------
11444 print_help_line
("--nowarnings",
11445 "Disable the printing of warning messages on stdout. By default");
11446 print_help_line
("",
11447 "warning messages are printed.");
11449 #-------Marker line - do not go beyond this line --------------------------
11451 printf ("%s\n","Report bugs to <https://sourceware.org/bugzilla/>");
11455 } #-- End of subroutine print_help_info
11457 #------------------------------------------------------------------------------
11458 # Print a single line as part of the help output.
11460 # If the first item is not the empty string, it is considered to be the
11461 # option. If the length of the option exceeds the limit set by $max_space,
11462 # it is printed by itself and the text is printed on the next line. Otherwise
11463 # the text follows the option.
11465 # To assist with the development of the help text, we check if the total length
11466 # of the line exceeds the max numbers of columns (79 according to the GNU
11467 # coding standards).
11468 #------------------------------------------------------------------------------
11469 sub print_help_line
11471 my $subr_name = get_my_name
();
11473 my ($item, $help_text) = @_;
11475 my $length_item = length ($item);
11477 my $max_space = 14;
11483 if ($length_item > $max_col)
11485 printf ("Error: $item is $length_item long - exceeds $max_col\n");
11488 elsif ( $length_item == 0 )
11490 $no_of_spaces = $max_space;
11493 for my $i (1..$no_of_spaces)
11497 $the_message = $pad . $help_text;
11501 if ($length_item < $max_space)
11503 $no_of_spaces = $max_space - length ($item);
11505 for my $i (1..$no_of_spaces)
11509 $the_message = $item . $pad . $help_text;
11514 for my $i (1..$max_space)
11518 printf("%s\n", $item);
11519 $the_message = $pad . $help_text;
11523 if (length ($the_message) <= $max_col)
11525 printf ("%s\n", $the_message);
11529 my $delta = length ($the_message) - $max_col;
11530 printf ("%s\n", "$the_message - exceeds $max_col by $delta");
11537 } #-- End of subroutine print_help_line
11539 #------------------------------------------------------------------------------
11540 # Print the meta data for each experiment directory.
11541 #------------------------------------------------------------------------------
11542 sub print_meta_data_experiments
11544 my $subr_name = get_my_name
();
11548 for my $exp (sort keys %g_exp_dir_meta_data)
11550 for my $meta (sort keys %{$g_exp_dir_meta_data{$exp}})
11552 gp_message
($mode, $subr_name, "$exp => $meta = $g_exp_dir_meta_data{$exp}{$meta}");
11558 } #-- End of subroutine print_meta_data_experiments
11560 #------------------------------------------------------------------------------
11561 # Brute force subroutine that prints the contents of a structure with function
11562 # level information. This version is for a top level array structure,
11563 # followed by a hash.
11564 #------------------------------------------------------------------------------
11565 sub print_metric_function_array
11567 my $subr_name = get_my_name
();
11569 my ($metric, $struct_type_name, $target_structure_ref) = @_;
11571 my @target_structure = @
{$target_structure_ref};
11573 gp_message
("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:");
11575 for my $fields (sort keys @target_structure)
11577 for my $elems (sort keys % {$target_structure[$fields]})
11579 my $msg = $struct_type_name."{$metric}[$fields]{$elems} = ";
11580 $msg .= $target_structure[$fields]{$elems};
11581 gp_message
("debugXL", $subr_name, $msg);
11587 } #-- End of subroutine print_metric_function_array
11589 #------------------------------------------------------------------------------
11590 # Brute force subroutine that prints the contents of a structure with function
11591 # level information. This version is for a top level hash structure. The
11592 # next level may be another hash, or an array.
11593 #------------------------------------------------------------------------------
11594 sub print_metric_function_hash
11596 my $subr_name = get_my_name
();
11598 my ($sub_struct_type, $metric, $struct_type_name, $target_structure_ref) = @_;
11600 my %target_structure = %{$target_structure_ref};
11602 gp_message
("debugXL", $subr_name, "contents of structure ".$struct_type_name."{".$metric."}:");
11604 for my $fields (sort keys %target_structure)
11606 gp_message
("debugXL", $subr_name, "metric = $metric fields = $fields");
11607 if ($sub_struct_type eq "hash_hash")
11609 for my $elems (sort keys %{$target_structure{$fields}})
11611 my $txt = $struct_type_name."{$metric}{$fields}{$elems} = ";
11612 $txt .= $target_structure{$fields}{$elems};
11613 gp_message
("debugXL", $subr_name, $txt);
11616 elsif ($sub_struct_type eq "hash_array")
11619 for my $elems (sort keys @
{$target_structure{$fields}})
11621 $values .= "$target_structure{$fields}[$elems] ";
11623 gp_message
("debugXL", $subr_name, $struct_type_name."{$metric}{$fields} = $values");
11627 my $msg = "sub-structure type '$sub_struct_type' is not supported";
11628 gp_message
("assertion", $subr_name, $msg);
11634 } #-- End of subroutine print_metric_function_hash
11636 #------------------------------------------------------------------------------
11637 # Print the opening message.
11638 #------------------------------------------------------------------------------
11639 sub print_opening_message
11641 my $subr_name = get_my_name
();
11642 #------------------------------------------------------------------------------
11643 # Since the second argument is an array, we pass it in by reference. The
11644 # alternative is to make it the last argument.
11645 #------------------------------------------------------------------------------
11646 my ($outputdir, $exp_dir_list_ref, $time_percentage_multiplier) = @_;
11648 my @exp_dir_list = @
{$exp_dir_list_ref};
11651 my $no_of_dirs = scalar (@exp_dir_list);
11652 #------------------------------------------------------------------------------
11653 # Build a comma separated list with all directory names. If there is only one
11654 # entry, the leading comma will not be inserted.
11655 #------------------------------------------------------------------------------
11656 my $dir_list = join (", ", @exp_dir_list);
11658 #------------------------------------------------------------------------------
11659 # If there are at least two entries, find the last comma and replace it by
11660 # " and". Note that we know there is at least one comma, so the value
11661 # returned by rindex () cannot be -1.
11662 #------------------------------------------------------------------------------
11663 if ($no_of_dirs > 1)
11665 my $last_comma = rindex ($dir_list, ",");
11666 my $ignore_value = substr ($dir_list, $last_comma, 1, " and");
11668 $msg = "start $tool_name, generating directory $outputdir from $dir_list";
11670 gp_message
("verbose", $subr_name, $msg);
11672 if ($time_percentage_multiplier < 1.0)
11674 $msg = "Handle at least ";
11681 $msg .= ($time_percentage_multiplier*100.0)."% of the time";
11683 gp_message
("verbose", $subr_name, $msg);
11685 } #-- End of subroutine print_opening_message
11687 #------------------------------------------------------------------------------
11689 #------------------------------------------------------------------------------
11690 sub print_program_header
11692 my $subr_name = get_my_name
();
11694 my ($mode, $tool_name, $binutils_version) = @_;
11696 my $header_limit = 60;
11699 #------------------------------------------------------------------------------
11700 # Generate the dashed line
11701 #------------------------------------------------------------------------------
11702 for (2 .. $header_limit)
11707 gp_message
($mode, $subr_name, $dashes);
11708 gp_message
($mode, $subr_name, "Tool name: $tool_name");
11709 gp_message
($mode, $subr_name, "Version : $binutils_version");
11710 gp_message
($mode, $subr_name, "Date : " . localtime ());
11711 gp_message
($mode, $subr_name, $dashes);
11713 } #-- End of subroutine print_program_header
11715 #------------------------------------------------------------------------------
11716 # Print a comment string, followed by the values of the options. The list
11717 # with the keywords is sorted alphabetically.
11719 # The value stored in $mode is passed on to gp_message (). The intended use
11720 # for this is to call this function in verbose and/or debug mode.
11722 # The comment string is converted to uppercase.
11724 # In case the length of the comment exceeds the length of the dashed line,
11725 # the comment line is allowed to stick out to the right.
11727 # If the length of the comment is less than the dashed line, it is centered
11728 # relative to the # length of the dashed line.
11730 # If the length of the comment and this line do not divide, an extra space is
11731 # added to the left of the comment.
11733 # For example, if the comment is 55 long, there are 5 spaces to be distributed.
11734 # There will be 3 spaces, followed by the comment.
11735 #------------------------------------------------------------------------------
11736 sub print_table_user_settings
11738 my $subr_name = get_my_name
();
11740 my ($mode, $comment) = @_;
11743 my $debug_size_value = $g_user_settings{"debug"}{"current_value"};
11752 my $HEADER_LIMIT = 79;
11753 my $header = sprintf ("%-20s %-22s %8s %s",
11754 "keyword", "option", "user set", "internal value");
11756 #------------------------------------------------------------------------------
11757 # Generate the dashed line
11758 #------------------------------------------------------------------------------
11760 for (2 .. $HEADER_LIMIT)
11765 #------------------------------------------------------------------------------
11766 # Determine the padding needed to the left of the comment.
11767 #------------------------------------------------------------------------------
11768 my $length_comment = length ($comment);
11770 $leftover = $length_comment%2;
11772 if ($length_comment <= ($HEADER_LIMIT-2))
11774 $padding = ($HEADER_LIMIT - $length_comment + $leftover)/2;
11781 #------------------------------------------------------------------------------
11782 # Generate the first blank part of the line.
11783 #------------------------------------------------------------------------------
11784 my $blank_line = "";
11785 for (1 .. $padding)
11787 $blank_line .= " ";
11790 #------------------------------------------------------------------------------
11791 # Add the comment line with the first letter in uppercase.
11792 #------------------------------------------------------------------------------
11793 my $final_comment = $blank_line.ucfirst ($comment);
11795 gp_message
($mode, $subr_name, $dashes);
11796 gp_message
($mode, $subr_name, $final_comment);
11797 gp_message
($mode, $subr_name, $dashes);
11798 gp_message
($mode, $subr_name, $header);
11799 gp_message
($mode, $subr_name, $dashes);
11801 #------------------------------------------------------------------------------
11802 # Print a line for each option. The list is sorted alphabetically.
11803 #------------------------------------------------------------------------------
11804 for my $key (sort keys %g_user_settings)
11807 $user_option = $g_user_settings{$key}{"option"};
11808 $defined = ($g_user_settings{$key}{"defined"} ?
"set" : "not set");
11809 $data_type = $g_user_settings{$key}{"data_type"};
11811 if (defined ($g_user_settings{$key}{"current_value"}))
11813 $value = $g_user_settings{$key}{"current_value"};
11814 if ($data_type eq "boolean")
11816 $value = $value ?
"on" : "off";
11818 #------------------------------------------------------------------------------
11819 # In case of the debug option, we add the "(size)" string to remind the user
11820 # that this is the size.
11821 #------------------------------------------------------------------------------
11822 if ($key eq "debug")
11824 $db_size = ($debug_size_value eq "on") ?
"s" : $debug_size_value;
11825 $value = $db_size . " (size)";
11830 $value = "undefined";
11833 my $print_line = sprintf ("%-20s %-22s %8s %s",
11834 $keyword, $user_option, $defined, $value);
11836 gp_message
($mode, $subr_name, $print_line);
11838 } #-- End of subroutine print_table_user_settings
11840 #------------------------------------------------------------------------------
11841 # Dump the contents of nested hash "g_user_settings". Some simple formatting
11842 # is applied to make it easier to distinguish the various values.
11843 #------------------------------------------------------------------------------
11844 sub print_user_settings
11846 my $subr_name = get_my_name
();
11848 my ($mode, $comment) = @_;
11850 my $keyword_value_pair;
11852 gp_message
($mode, $subr_name, $comment);
11854 for my $key (keys %g_user_settings)
11856 my $print_line = sprintf ("%-20s =>", $key);
11857 for my $fields (sort keys %{ $g_user_settings{$key} })
11859 if (defined ($g_user_settings{$key}{$fields}))
11861 $keyword_value_pair = $fields." = ".$g_user_settings{$key}{$fields};
11865 $keyword_value_pair = $fields." = ". "undefined";
11867 $print_line = join (" ", $print_line, $keyword_value_pair);
11869 gp_message
($mode, $subr_name, $print_line);
11871 } #-- End of subroutine print_user_settings
11873 #------------------------------------------------------------------------------
11874 # Print the version number and license information.
11875 #------------------------------------------------------------------------------
11876 sub print_version_info
11878 print "$version_info\n";
11879 print "Copyright (C) 2023 Free Software Foundation, Inc.\n";
11880 print "License GPLv3+: GNU GPL version 3 or later <https://gnu.org/licenses/gpl.html>.\n";
11881 print "This is free software: you are free to change and redistribute it.\n";
11882 print "There is NO WARRANTY, to the extent permitted by law.\n";
11886 } #-- End of subroutine print_version_info
11888 #------------------------------------------------------------------------------
11889 # Dump all the warning messages in the buffer.
11890 #------------------------------------------------------------------------------
11891 sub print_warnings_buffer
11893 my $subr_name = get_my_name
();
11898 if (not $g_options_printed)
11899 #------------------------------------------------------------------------------
11900 # Only if the options have not yet been printed, print them.
11901 #------------------------------------------------------------------------------
11903 $g_options_printed = $TRUE;
11904 $ignore_value = print_command_line_options
(\
$g_warn_keyword);
11907 for my $i (keys @g_warning_msgs)
11909 $msg = $g_warning_msgs[$i];
11910 if ($msg =~ /^$g_html_new_line/)
11912 $msg =~ s/$g_html_new_line//;
11913 printf ("%-9s\n", $g_warn_keyword);
11915 printf ("%-9s %s\n", $g_warn_keyword, ucfirst ($msg));
11920 } #-- End of subroutine print_warnings_buffer
11922 #------------------------------------------------------------------------------
11923 # Process the call tree input data and generate HTML output.
11924 #------------------------------------------------------------------------------
11925 sub process_calltree
11927 my $subr_name = get_my_name
();
11929 my ($function_info_ref, $function_address_info_ref, $addressobjtextm_ref,
11930 $input_string) = @_;
11932 my @function_info = @
{ $function_info_ref };
11933 my %function_address_info = %{ $function_address_info_ref };
11934 my %addressobjtextm = %{ $addressobjtextm_ref };
11936 my $outputdir = append_forward_slash
($input_string);
11938 my @call_tree_data = ();
11940 my $LANG = $g_locale_settings{"LANG"};
11941 my $decimal_separator = $g_locale_settings{"decimal_separator"};
11943 my $infile = $outputdir . "calltree";
11944 my $outfile = $outputdir . "calltree.html";
11946 open (CALL_TREE_IN
, "<", $infile)
11947 or die ("Not able to open calltree file $infile for reading - '$!'");
11948 gp_message
("debug", $subr_name, "opened file $infile for reading");
11950 open (CALL_TREE_OUT
, ">", $outfile)
11951 or die ("Not able to open $outfile for writing - '$!'");
11952 gp_message
("debug", $subr_name, "opened file $outfile for writing");
11954 gp_message
("debug", $subr_name, "building calltree file $outfile");
11956 #------------------------------------------------------------------------------
11957 # The directory name is potentially used below, but since it is a constant,
11958 # we get it here and only once.
11959 #------------------------------------------------------------------------------
11960 # my ($ignore_file_name, $directory_name, $ignore_suffix) = fileparse ($infile,"");
11961 # gp_message ("debug", $subr_name, "directory_name = $directory_name");
11963 #------------------------------------------------------------------------------
11964 # Generate some of the structures used in the HTML output.
11965 #------------------------------------------------------------------------------
11966 my $file_title = "Call Tree overview";
11967 my $html_header = ${ create_html_header
(\
$file_title) };
11968 my $html_home_right = ${ generate_home_link
("right") };
11970 my $page_title = "Call Tree View";
11971 my $size_text = "h2";
11972 my $position_text = "center";
11973 my $html_title_header = ${ generate_a_header
(
11976 \
$position_text) };
11978 #------------------------------------------------------------------------------
11979 # Get the acknowledgement, return to main link, and final html statements.
11980 #------------------------------------------------------------------------------
11981 my $html_home_left = ${ generate_home_link
("left") };
11982 my $html_acknowledgement = ${ create_html_credits
() };
11983 my $html_end = ${ terminate_html_document
() };
11985 #------------------------------------------------------------------------------
11986 # Read all of the file into array with the name call_tree_data.
11987 #------------------------------------------------------------------------------
11988 chomp (@call_tree_data = <CALL_TREE_IN
>);
11989 close (CALL_TREE_IN
);
11991 #------------------------------------------------------------------------------
11992 #------------------------------------------------------------------------------
11993 # Process the data here and generate the HTML lines.
11994 #------------------------------------------------------------------------------
11995 #------------------------------------------------------------------------------
11997 #------------------------------------------------------------------------------
11998 # Print the top part of the HTML file.
11999 #------------------------------------------------------------------------------
12000 print CALL_TREE_OUT
$html_header;
12001 print CALL_TREE_OUT
$html_home_right;
12002 print CALL_TREE_OUT
$html_title_header;
12004 #------------------------------------------------------------------------------
12005 # Print the generated HTML structures here.
12006 #------------------------------------------------------------------------------
12007 ## print CALL_TREE_OUT "$_" for @whatever;
12008 ## print CALL_TREE_OUT "<pre>\n";
12009 ## print CALL_TREE_OUT "$_\n" for @whatever2;
12010 ## print CALL_TREE_OUT "</pre>\n";
12012 #------------------------------------------------------------------------------
12013 # Print the last part of the HTML file.
12014 #------------------------------------------------------------------------------
12015 print CALL_TREE_OUT
$html_home_left;
12016 print CALL_TREE_OUT
"<br>\n";
12017 print CALL_TREE_OUT
$html_acknowledgement;
12018 print CALL_TREE_OUT
$html_end;
12020 close (CALL_TREE_OUT
);
12024 } #-- End of subroutine process_calltree
12026 #------------------------------------------------------------------------------
12027 # Process the generated experiment info file(s).
12028 #------------------------------------------------------------------------------
12029 sub process_experiment_info
12031 my $subr_name = get_my_name
();
12033 my ($experiment_data_ref) = @_;
12036 my @experiment_data = @
{ $experiment_data_ref };
12048 my $end_experiment;
12049 my $data_collection_duration;
12050 my $total_thread_time;
12052 my $user_cpu_percentage;
12053 my $system_cpu_time;
12054 my $system_cpu_percentage;
12056 my $sleep_percentage;
12058 #------------------------------------------------------------------------------
12059 # Define the regular expressions used to capture the info.
12060 #------------------------------------------------------------------------------
12061 # Target command (64-bit): './../bindir/mxv-pthreads.exe -m 3000 -n 2000 -t 2'
12063 my $target_cmd_regex = '\s*Target command\s+(\(.+\)):\s+\'(.+)\'';
12065 # Host `ruudvan-vm-haswell-2-20210609', OS `Linux 5.4.17-2102.202.5.el8uek.x86_64', page size 4096, architecture `x86_64'
12067 my $host_system_regex = '\s*Host\s+\`(.+)\',\s+OS\s+\`(.+)\',\s+page size\s+(\d+),\s+architecture\s+\`(.+)\'';
12069 # Experiment started Mon Aug 30 13:03:20 2021
12071 my $start_date_regex = '\s*Experiment started\s+(.+)';
12073 # Experiment Ended: 1.812441219
12075 my $end_experiment_regex = '\s*Experiment Ended:\s+(.+)';
12077 # Data Collection Duration: 1.812441219
12079 my $data_collection_duration_regex = '\s*Data Collection Duration:\s+(.+)';
12081 # Total Thread Time (sec.): 1.812
12083 my $total_thread_time_regex = '\s*Total Thread Time (sec.):\s+(.+)';
12085 # User CPU: 1.685 ( 95.0%)
12087 my $user_cpu_regex = '\s*User CPU:\s+(.+)\s+\(\s*(.+)\)';
12089 # System CPU: 0.088 ( 5.0%)
12091 my $system_cpu_regex = '\s*System CPU:\s+(.+)\s+\(\s*(.+)\)';
12093 # Sleep: 0. ( 0. %)
12095 my $sleep_regex = '\s*Sleep:\s+(.+)\s+\(\s*(.+)\)';
12097 #------------------------------------------------------------------------------
12098 # Scan the experiment data and select the info of interest.
12099 #------------------------------------------------------------------------------
12100 for my $i (sort keys @experiment_data)
12102 $exp_id = $experiment_data[$i]{"exp_id"};
12103 $exp_name = $experiment_data[$i]{"exp_name_full"};
12104 $exp_data_file = $experiment_data[$i]{"exp_data_file"};
12106 my $msg = "exp_id = $exp_id name = $exp_name file = $exp_data_file";
12107 gp_message
("debug", $subr_name, $msg);
12109 open (EXPERIMENT_INFO
, "<", $exp_data_file)
12110 or die ("$subr_name - unable to open file $exp_data_file for reading '$!'");
12111 gp_message
("debug", $subr_name, "opened file $exp_data_file for reading");
12113 chomp (@exp_info = <EXPERIMENT_INFO
>);
12115 #------------------------------------------------------------------------------
12116 # Process the info for the current experiment.
12117 #------------------------------------------------------------------------------
12118 for my $line (0 .. $#exp_info)
12120 $input_line = $exp_info[$line];
12122 my $msg = "exp_id = $exp_id: input_line = $input_line";
12123 gp_message
("debugM", $subr_name, $msg);
12125 if ($input_line =~ /$target_cmd_regex/)
12128 gp_message
("debugM", $subr_name, "$exp_id => $target_cmd");
12129 $experiment_data[$i]{"target_cmd"} = $target_cmd;
12131 elsif ($input_line =~ /$host_system_regex/)
12136 $architecture = $4;
12137 gp_message
("debugM", $subr_name, "$exp_id => $hostname $OS $page_size $architecture");
12138 $experiment_data[$i]{"hostname"} = $hostname;
12139 $experiment_data[$i]{"OS"} = $OS;
12140 $experiment_data[$i]{"page_size"} = $page_size;
12141 $experiment_data[$i]{"architecture"} = $architecture;
12143 elsif ($input_line =~ /$start_date_regex/)
12146 gp_message
("debugM", $subr_name, "$exp_id => $start_date");
12147 $experiment_data[$i]{"start_date"} = $start_date;
12149 elsif ($input_line =~ /$end_experiment_regex/)
12151 $end_experiment = $1;
12152 gp_message
("debugM", $subr_name, "$exp_id => $end_experiment");
12153 $experiment_data[$i]{"end_experiment"} = $end_experiment;
12155 elsif ($input_line =~ /$data_collection_duration_regex/)
12157 $data_collection_duration = $1;
12158 gp_message
("debugM", $subr_name, "$exp_id => $data_collection_duration");
12159 $experiment_data[$i]{"data_collection_duration"} = $data_collection_duration;
12161 #------------------------------------------------------------------------------
12162 # Start Label: Total
12164 # Start Time (sec.): 0.000
12165 # End Time (sec.): 1.812
12166 # Duration (sec.): 1.812
12167 # Total Thread Time (sec.): 1.812
12168 # Average number of Threads: 1.000
12170 # Process Times (sec.):
12171 # User CPU: 1.666 ( 91.9%)
12172 # System CPU: 0.090 ( 5.0%)
12173 # Trap CPU: 0. ( 0. %)
12174 # User Lock: 0. ( 0. %)
12175 # Data Page Fault: 0. ( 0. %)
12176 # Text Page Fault: 0. ( 0. %)
12177 # Kernel Page Fault: 0. ( 0. %)
12178 # Stopped: 0. ( 0. %)
12179 # Wait CPU: 0. ( 0. %)
12180 # Sleep: 0.056 ( 3.1%)
12181 #------------------------------------------------------------------------------
12182 elsif ($input_line =~ /$total_thread_time_regex/)
12184 $total_thread_time = $1;
12185 gp_message
("debugM", $subr_name, "$exp_id => $total_thread_time");
12186 $experiment_data[$i]{"total_thread_time"} = $total_thread_time;
12188 elsif ($input_line =~ /$user_cpu_regex/)
12190 $user_cpu_time = $1;
12191 $user_cpu_percentage = $2;
12192 gp_message
("debugM", $subr_name, "$exp_id => $user_cpu_time $user_cpu_percentage");
12193 $experiment_data[$i]{"user_cpu_time"} = $user_cpu_time . " (" . $user_cpu_percentage . ")";
12194 $experiment_data[$i]{"user_cpu_percentage"} = $user_cpu_percentage;
12196 elsif ($input_line =~ /$system_cpu_regex/)
12198 $system_cpu_time = $1;
12199 $system_cpu_percentage = $2;
12200 gp_message
("debugM", $subr_name, "$exp_id => $system_cpu_time $system_cpu_percentage");
12201 $experiment_data[$i]{"system_cpu_time"} = $system_cpu_time . " (" . $system_cpu_percentage . ")";
12202 $experiment_data[$i]{"system_cpu_percentage"} = $system_cpu_percentage;
12204 elsif ($input_line =~ /$sleep_regex/)
12207 $sleep_percentage = $2;
12208 $experiment_data[$i]{"sleep_time"} = $sleep_time . " (" . $sleep_percentage . ")";
12209 $experiment_data[$i]{"sleep_percentage"} = $sleep_percentage;
12211 my $msg = "exp_id = $exp_id => sleep_time = $sleep_time " .
12212 "sleep_percentage = $sleep_percentage";
12213 gp_message
("debugM", $subr_name, $msg);
12218 for my $keys (0 .. $#experiment_data)
12220 for my $fields (sort keys %{ $experiment_data[$keys] })
12222 my $msg = "experiment_data[$keys]{$fields} = " .
12223 $experiment_data[$keys]{$fields};
12224 gp_message
("debugM", $subr_name, $msg);
12228 return (\
@experiment_data);
12230 } #-- End of subroutine process_experiment_info
12232 #------------------------------------------------------------------------------
12234 #------------------------------------------------------------------------------
12235 sub process_function_files
12237 my $subr_name = get_my_name
();
12239 my ($exp_dir_list_ref, $executable_name, $time_percentage_multiplier,
12240 $summary_metrics, $process_all_functions, $elf_loadobjects_found,
12241 $outputdir, $sort_fields_ref, $function_info_ref,
12242 $function_address_and_index_ref, $LINUX_vDSO_ref,
12243 $metric_description_ref, $elf_arch, $base_va_executable,
12244 $ARCHIVES_MAP_NAME, $ARCHIVES_MAP_VADDR, $elf_rats_ref) = @_;
12247 my $total_attributed_time;
12248 my $current_attributed_time;
12251 my @exp_dir_list = @
{ $exp_dir_list_ref };
12252 my @function_info = @
{ $function_info_ref };
12253 my %function_address_and_index = %{ $function_address_and_index_ref };
12254 my @sort_fields = @
{ $sort_fields_ref };
12255 my %metric_description = %{ $metric_description_ref };
12256 my %elf_rats = %{ $elf_rats_ref };
12258 #------------------------------------------------------------------------------
12259 # The regex section.
12261 # TBD: Remove the part regarding clones. Legacy.
12262 #------------------------------------------------------------------------------
12263 my $replace_quote_regex = '"/\"';
12264 my $find_clone_regex = '^(.*)(\s+--\s+cloned\s+version\s+\[)([^]]+)(\])';
12266 my %addressobj_index = ();
12267 my %function_address_info = ();
12268 my $function_address_info_ref;
12270 $outputdir = append_forward_slash
($outputdir);
12272 my %functions_per_metric_indexes = ();
12273 my $functions_per_metric_indexes_ref;
12275 my %functions_per_metric_first_index = ();
12276 my $functions_per_metric_first_index_ref;
12278 my %routine_list = ();
12279 my %handled_routines = ();
12281 #------------------------------------------------------------------------------
12282 # TBD: Name cleanup needed.
12283 #------------------------------------------------------------------------------
12285 my $number_of_metrics;
12293 my $n_metrics_text;
12297 my $gp_listings_cmd;
12298 my $gp_display_text_cmd;
12301 my $result_file = $outputdir . "gp-listings.out";
12302 my $gp_error_file = $outputdir . "gp-listings.err";
12304 my $convert_to_dot = $g_locale_settings{"convert_to_dot"};
12305 my $decimal_separator = $g_locale_settings{"decimal_separator"};
12306 my $length_of_string = length ($outputdir);
12308 $expr_name = join (" ", @exp_dir_list);
12310 gp_message
("debug", $subr_name, "expr_name = $expr_name");
12312 #------------------------------------------------------------------------------
12313 # Loop over the files in $outputdir.
12314 #------------------------------------------------------------------------------
12315 while (glob ($outputdir.'*.sort.func-PC'))
12320 my $suffix_not_used;
12324 ($metric, $ignore_value, $suffix_not_used) = fileparse
($infile, ".sort.func-PC");
12326 gp_message
("debugXL", $subr_name, "suffix_not_used = $suffix_not_used");
12327 gp_message
("debugXL", $subr_name, "func-PC->$infile<- metric->$metric<-");
12329 # Function_info creates the functions files from the PC ones
12330 # as well as culling PC and metric information
12332 ($function_address_info_ref,
12333 $functions_per_metric_first_index_ref,
12334 $functions_per_metric_indexes_ref) = function_info
(
12340 @
{$function_address_info{$metric}} = @
{$function_address_info_ref};
12341 %{$functions_per_metric_indexes{$metric}} = %{$functions_per_metric_indexes_ref};
12342 %{$functions_per_metric_first_index{$metric}} = %{$functions_per_metric_first_index_ref};
12344 $ignore_value = print_metric_function_array
($metric,
12345 "function_address_info",
12346 \@
{$function_address_info{$metric}});
12347 $ignore_value = print_metric_function_hash
("hash_hash", $metric,
12348 "functions_per_metric_first_index",
12349 \
%{$functions_per_metric_first_index{$metric}});
12350 $ignore_value = print_metric_function_hash
("hash_array", $metric,
12351 "functions_per_metric_indexes",
12352 \
%{$functions_per_metric_indexes{$metric}});
12355 #------------------------------------------------------------------------------
12356 # Get header info for use in post processing er_html output
12357 #------------------------------------------------------------------------------
12358 gp_message
("debugXL", $subr_name, "get_hdr_info section");
12360 get_hdr_info
($outputdir, $outputdir."functions.sort.func");
12362 for my $field (@sort_fields)
12364 get_hdr_info
($outputdir, $outputdir."$field.sort.func");
12367 #------------------------------------------------------------------------------
12369 #------------------------------------------------------------------------------
12370 get_hdr_info
($outputdir, $outputdir."calls.sort.func");
12372 #------------------------------------------------------------------------------
12374 #------------------------------------------------------------------------------
12375 if ($g_user_settings{"calltree"}{"current_value"} eq "on")
12377 get_hdr_info
($outputdir, $outputdir."calltree.sort.func");
12380 gp_message
("debug", $subr_name, "process functions");
12382 my $scriptfile = $outputdir.'gp-script';
12383 my $script_metrics = "$summary_metrics";
12384 my $func_limit = $g_user_settings{"func_limit"}{"current_value"};
12386 open (SCRIPT
, ">", $scriptfile)
12387 or die ("Unable to create script file $scriptfile - '$!'");
12388 gp_message
("debug", $subr_name, "opened script file $scriptfile for writing");
12390 print SCRIPT
"# limit $func_limit\n";
12391 print SCRIPT
"limit $func_limit\n";
12392 print SCRIPT
"# thread_select all\n";
12393 print SCRIPT
"thread_select all\n";
12394 print SCRIPT
"# metrics $script_metrics\n";
12395 print SCRIPT
"metrics $script_metrics\n";
12397 for my $metric (@sort_fields)
12399 gp_message
("debug", $subr_name, "handling $metric->$metric_description{$metric}");
12401 $total_attributed_time = 0;
12402 $current_attributed_time = 0;
12404 $value = $function_address_info{$metric}[0]{"metric_value"}; # <Total>
12405 if ($convert_to_dot)
12407 $value =~ s/$decimal_separator/\./;
12409 $total_attributed_time = $value;
12411 #------------------------------------------------------------------------------
12412 # start at 1 - skipping <Total>
12413 #------------------------------------------------------------------------------
12414 for my $INDEX (1 .. $#{$function_address_info{$metric}})
12416 #------------------------------------------------------------------------------
12417 #Looking to handle at least 99% of the time - or what the user asked for
12418 #------------------------------------------------------------------------------
12419 $value = $function_address_info{$metric}[$INDEX]{"metric_value"};
12420 $routine = $function_address_info{$metric}[$INDEX]{"routine"};
12422 gp_message
("debugXL", $subr_name, " total $total_attributed_time current $current_attributed_time");
12423 gp_message
("debugXL", $subr_name, " (found routine $routine : value $value)");
12425 if ($convert_to_dot)
12427 $value =~ s/$decimal_separator/\./;
12430 if ( ($value > $total_attributed_time*(1-$time_percentage_multiplier)) or
12431 ( ($total_attributed_time == 0) and ($value>0) ) or
12432 $process_all_functions)
12434 $PCA = $function_address_info{$metric}[$INDEX]{"PC Address"};
12436 if (not exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}))
12438 gp_message
("debugXL", $subr_name, "not exists: functions_per_metric_first_index{$metric}{$routine}{$PCA}");
12440 if (not exists ($function_address_and_index{$routine}{$PCA}))
12442 gp_message
("debugXL", $subr_name, "not exists: function_address_and_index{$routine}{$PCA}");
12445 if (exists ($functions_per_metric_first_index{$metric}{$routine}{$PCA}) and
12446 exists ($function_address_and_index{$routine}{$PCA}))
12448 #------------------------------------------------------------------------------
12449 # handled_routines now contains $RI from "first_metric" (?)
12450 #------------------------------------------------------------------------------
12451 $handled_routines{$function_address_and_index{$routine}{$PCA}} = 1;
12452 my $description = ${ retrieve_metric_description
(\
$metric, \
%metric_description) };
12453 if ($metric_description{$metric} =~ /Exclusive Total CPU Time/)
12455 $routine_list{$routine} = 1
12458 gp_message
("debugXL", $subr_name, " $routine is candidate");
12462 die ("internal error for metric $metric and routine $routine");
12465 $current_attributed_time += $value;
12469 #------------------------------------------------------------------------------
12470 # Sort numerically in ascending order.
12471 #------------------------------------------------------------------------------
12472 for my $routine_index (sort {$a <=> $b} keys %handled_routines)
12474 $routine = $function_info[$routine_index]{"routine"};
12475 gp_message
("debugXL", $subr_name, "routine_index = $routine_index routine = $routine");
12476 next unless $routine_list{$routine};
12478 # not used $source = $function_info[$routine_index]{"Source File"};
12480 $function_info[$routine_index]{"srcline"} = "";
12481 $address_field = $function_info[$routine_index]{"addressobjtext"};
12483 ## $disfile = "file\.$routine_index\.dis";
12484 $disfile = "file." . $routine_index . "." . $g_html_base_file_name{"disassembly"};
12486 $srcfile = "file\.$routine_index\.src.txt";
12488 #------------------------------------------------------------------------------
12489 # If the file is unknown, we can disassemble anyway and add disassembly
12491 #------------------------------------------------------------------------------
12492 print SCRIPT
"# outfile $outputdir"."$disfile\n";
12493 print SCRIPT
"outfile $outputdir"."$disfile\n";
12494 #------------------------------------------------------------------------------
12495 # TBD: Legacy. Not sure why this is needed, but it won't harm things. I hope.
12496 #------------------------------------------------------------------------------
12498 $tmp =~ s/$replace_quote_regex//g;
12499 print SCRIPT
"# disasm \"$tmp\" $address_field\n";
12500 print SCRIPT
"disasm \"$tmp\" $address_field\n";
12501 if ($srcfile=~/file/)
12503 print SCRIPT
"# outfile $outputdir"."$srcfile\n";
12504 print SCRIPT
"outfile $outputdir"."$srcfile\n";
12505 print SCRIPT
"# source \"$tmp\" $address_field\n";
12506 print SCRIPT
"source \"$tmp\" $address_field\n";
12509 if ($routine =~ /$find_clone_regex/)
12511 my ($clone_routine) = $1.$2.$3.$4;
12517 #------------------------------------------------------------------------------
12518 # Remember the number of handled routines depends on the limit setting passed
12519 # to er_print together with the sorting order on the metrics, which usually results
12520 # in different routines at the top. Thus $RIN below can be greater than the limit.
12521 #------------------------------------------------------------------------------
12523 $RIN = scalar (keys %handled_routines);
12527 $limit_txt = "unlimited";
12531 $limit_txt = $func_limit - 1;
12534 $number_of_metrics = scalar (@sort_fields);
12536 $n_metrics_text = ($number_of_metrics == 1) ?
"metric" : "metrics";
12538 gp_message
("debugXL", $subr_name, "built function list with $RIN functions");
12539 gp_message
("debugXL", $subr_name, "$number_of_metrics $n_metrics_text and a function limit of $limit_txt");
12541 # add ELF program header offset
12543 for my $routine_index (sort {$a <=> $b} keys %handled_routines)
12545 $routine = $function_info[$routine_index]{"routine"};
12546 $loadobj = $function_info[$routine_index]{"Load Object"};
12548 gp_message
("debugXL", $subr_name, "routine = $routine loadobj = $loadobj elf_arch = $elf_arch");
12550 if ($loadobj ne '')
12552 # <Truncated-stack> is associated with <Total>. Its load object is <Total>
12553 if ($loadobj eq "<Total>")
12557 # Have seen a routine called <Unknown>. Its load object is <Unknown>
12558 if ($loadobj eq "<Unknown>")
12562 ###############################################################################
12563 ## RUUD: The new approach gives a different result. Investigate this.
12565 # Turns out the new code improves the result. The addresses are now correct
12566 # and as a result, more ftag's are created later on.
12567 ###############################################################################
12568 gp_message
("debugXL", $subr_name, "before function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}");
12570 $function_info[$routine_index]{"addressobj"} += bigint
::hex (
12571 determine_base_va_address
(
12573 $base_va_executable,
12576 $addressobj_index{$function_info[$routine_index]{"addressobj"}} = $routine_index;
12578 gp_message
("debugXL", $subr_name, "after function_info[$routine_index]{addressobj} = $function_info[$routine_index]{'addressobj'}");
12579 gp_message
("debugXL", $subr_name, "after addressobj_index{function_info[$routine_index]{addressobj}} = $addressobj_index{$function_info[$routine_index]{'addressobj'}}");
12583 #------------------------------------------------------------------------------
12584 # Get the disassembly and source code output.
12585 #------------------------------------------------------------------------------
12586 $gp_listings_cmd = "$GP_DISPLAY_TEXT -limit $func_limit -viewmode machine " .
12587 "-compare off -script $scriptfile $expr_name";
12589 $gp_display_text_cmd = "$gp_listings_cmd 1> $result_file 2>> $gp_error_file";
12591 gp_message
("debugXL", $subr_name,"gp_display_text_cmd = $gp_display_text_cmd");
12593 gp_message
("debug", $subr_name, "calling $GP_DISPLAY_TEXT to produce disassembly and source code output");
12595 my ($error_code, $cmd_output) = execute_system_cmd
($gp_display_text_cmd);
12597 if ($error_code != 0)
12599 $ignore_value = msg_display_text_failure
($gp_display_text_cmd,
12602 gp_message
("abort", $subr_name, "execution terminated");
12605 return (\
@function_info, \
%function_address_info, \
%addressobj_index);
12607 } #-- End of subroutine process_function_files
12609 #------------------------------------------------------------------------------
12610 # Process the information found in the function overview file passed in.
12614 # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
12615 # Functions sorted by metric: Exclusive Total CPU Time
12617 # PC Addr. Name Excl. Excl. CPU Excl. Excl. Excl. Excl.
12618 # Total Cycles Instructions Last-Level IPC CPI
12619 # CPU sec. sec. Executed Cache Misses
12620 # 1:0x00000000 <Total> 3.713 4.256 15396819712 27727992 1.577 0.634
12621 # 2:0x000021ae mxv_core 3.532 4.116 14500538992 27527781 1.536 0.651
12622 # 2:0x00001f7b init_data 0.070 0.084 64020034 200211 0.333 3.000
12623 #------------------------------------------------------------------------------
12624 sub process_function_overview
12626 my $subr_name = get_my_name
();
12628 my ($metric_ref, $exp_type_ref, $summary_metrics_ref, $number_of_metrics_ref,
12629 $function_info_ref, $function_view_structure_ref, $overview_file_ref) = @_;
12631 my $metric = ${ $metric_ref };
12632 my $exp_type = ${ $exp_type_ref };
12633 my $summary_metrics = ${ $summary_metrics_ref };
12634 my $number_of_metrics = ${ $number_of_metrics_ref };
12635 my @function_info = @
{ $function_info_ref };
12636 my %function_view_structure = %{ $function_view_structure_ref };
12637 my $overview_file = ${ $overview_file_ref };
12640 my $decimal_separator = $g_locale_settings{"decimal_separator"};
12641 my $length_of_block;
12642 my $elements_in_name;
12643 my $full_hex_address;
12650 my $metrics_length;
12651 my $missing_digits;
12652 my $remaining_part_header;
12654 my $routine_length;
12655 my $scan_header = $FALSE;
12656 my $scan_function_data = $FALSE;
12658 my $total_header_lines;
12660 my @address_field = ();
12662 my @function_data = ();
12663 my @function_names = ();
12664 my @function_view_array = ();
12665 my @function_view_modified = ();
12666 my @header_lines = ();
12667 my @metrics_part = ();
12668 my @metric_values = ();
12670 #------------------------------------------------------------------------------
12671 # The regex section.
12672 #------------------------------------------------------------------------------
12673 my $header_name_regex = '(.*\.)(\s+)(Name)\s+(.*)';
12674 my $total_marker_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(<Total>)\s+(.*)';
12675 my $empty_line_regex = '^\s*$';
12676 my $catch_all_regex = '\s*(.*)';
12677 my $get_hex_address_regex = '(\d+):0x(\S+)';
12678 my $get_addr_offset_regex = '^@\d+:';
12679 my $zero_dot_at_end_regex = '[\w0-9' . $decimal_separator . ']*(0' . $decimal_separator . '$)';
12680 my $backward_slash_regex = '\/';
12682 #------------------------------------------------------------------------------
12683 if (is_file_empty
($overview_file))
12685 gp_message
("assertion", $subr_name, "file $overview_file is empty");
12688 open (FUNC_OVERVIEW
, "<", $overview_file)
12689 or die ("$subr_name - unable to open file $overview_file for reading '$!'");
12690 gp_message
("debug", $subr_name, "opened file $overview_file for reading");
12692 gp_message
("debug", $subr_name, "processing file for exp_type = $exp_type");
12694 gp_message
("debugM", $subr_name, "header_name_regex = $header_name_regex");
12695 gp_message
("debugM", $subr_name, "total_marker_regex = $total_marker_regex");
12696 gp_message
("debugM", $subr_name, "empty_line_regex = $empty_line_regex");
12697 gp_message
("debugM", $subr_name, "catch_all_regex = $catch_all_regex");
12698 gp_message
("debugM", $subr_name, "get_hex_address_regex = $get_hex_address_regex");
12699 gp_message
("debugM", $subr_name, "get_addr_offset_regex = $get_addr_offset_regex");
12700 gp_message
("debugM", $subr_name, "zero_dot_at_end_regex = $zero_dot_at_end_regex");
12701 gp_message
("debugM", $subr_name, "backward_slash_regex = $backward_slash_regex");
12703 #------------------------------------------------------------------------------
12704 # Read the input file into memory.
12705 #------------------------------------------------------------------------------
12706 chomp (@function_data = <FUNC_OVERVIEW
>);
12707 gp_message
("debug", $subr_name, "read all of file $overview_file into memory");
12709 #------------------------------------------------------------------------------
12710 # Parse the function view info and store the data.
12711 #------------------------------------------------------------------------------
12712 my $max_header_length = 0;
12713 my $max_metrics_length = 0;
12715 #------------------------------------------------------------------------------
12716 # Loop over all the lines. Extract the header, metric values, function names,
12717 # and the addresses.
12719 # This is also where the maximum lengths for the header and metric lines are
12720 # computed. This is used to get the correct alignment in the HTML output.
12721 #------------------------------------------------------------------------------
12722 for (my $line = 0; $line <= $#function_data; $line++)
12724 $input_line = $function_data[$line];
12725 gp_message
("debugXL", $subr_name, "input_line = $input_line");
12727 #------------------------------------------------------------------------------
12728 # The table header is assumed to start at the line that has "Name" in it.
12729 # The header ends when we see the function name "<Total>".
12730 #------------------------------------------------------------------------------
12731 if ($input_line =~ /$header_name_regex/)
12733 $scan_header = $TRUE;
12735 elsif ($input_line =~ /$total_marker_regex/)
12737 $scan_header = $FALSE;
12738 $scan_function_data = $TRUE;
12743 #------------------------------------------------------------------------------
12744 # This group is only defined for the first line of the header and $4 contains
12745 # the remaining part of the line after "Name", without the leading spaces.
12746 #------------------------------------------------------------------------------
12749 $remaining_part_header = $4;
12750 my $msg = "remaining_part_header = $remaining_part_header";
12751 gp_message
("debugXL", $subr_name, $msg);
12753 #------------------------------------------------------------------------------
12754 # Determine the maximum length of the header. This needs to be done before
12755 # the HTML controls are added.
12756 #------------------------------------------------------------------------------
12757 my $header_length = length ($remaining_part_header);
12758 $max_header_length = max
($max_header_length, $header_length);
12760 #------------------------------------------------------------------------------
12761 # TBD Should change this and not yet include html in header_lines
12762 #------------------------------------------------------------------------------
12763 $html_line = "<b>" . $remaining_part_header . "</b>";
12765 push (@header_lines, $html_line);
12767 gp_message
("debugXL", $subr_name, "max_header_length = $max_header_length");
12768 gp_message
("debugXL", $subr_name, "html_line = $html_line");
12770 #------------------------------------------------------------------------------
12771 # Captures the subsequent header lines. Assume they exist.
12772 #------------------------------------------------------------------------------
12773 elsif ($input_line =~ /$catch_all_regex/)
12776 gp_message
("debugXL", $subr_name, "header_line = $header_line");
12778 my $header_length = length ($header_line);
12779 $max_header_length = max
($max_header_length, $header_length);
12781 #------------------------------------------------------------------------------
12782 # TBD Should change this and not yet include html in header_lines
12783 #------------------------------------------------------------------------------
12784 $html_line = "<b>" . $header_line . "</b>";
12786 push (@header_lines, $html_line);
12788 gp_message
("debugXL", $subr_name, "max_header_length = $max_header_length");
12789 gp_message
("debugXL", $subr_name, "html_line = $html_line");
12792 #------------------------------------------------------------------------------
12793 # This is a line with function data.
12794 #------------------------------------------------------------------------------
12795 if ($scan_function_data and (not ($input_line =~ /$empty_line_regex/)))
12797 @fields = split (" ", $input_line);
12799 $no_of_fields = $#fields + 1;
12800 $elements_in_name = $no_of_fields - $number_of_metrics - 1;
12802 gp_message
("debugXL", $subr_name, "no_of_fields = $no_of_fields elements_in_name = $elements_in_name");
12804 #------------------------------------------------------------------------------
12805 # TBD: Handle this better in case a function entry has more than 2 words.
12806 # Build the regex dynamically and use eval to capture the correct group.
12807 # CHECK CODE IN GENERATE_CALLER_CALLEE
12808 #------------------------------------------------------------------------------
12809 if ($elements_in_name == 1)
12811 $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+(\S+)\s+(.*)';
12813 elsif ($elements_in_name == 2)
12815 $name_regex = '\s*(\d+:0x[a-fA-F0-9]+)\s+((\S+)\s+(\S+))\s+(.*)';
12819 gp_message
("error", $subr_name, "assertion error: $elements_in_name elements in name exceeds limit");
12822 if ($input_line =~ /$name_regex/)
12824 $full_hex_address = $1;
12827 if ($elements_in_name == 1)
12831 elsif ($elements_in_name == 2)
12836 #------------------------------------------------------------------------------
12837 # In case the last metric is 0. only, we append 3 extra characters that
12838 # represent zero. We cannot change the number to 0.000 though because that
12839 # has a different interpretation than 0.
12840 # In a later phase, the "ZZZ" symbol will be removed again, but for now it
12841 # creates consistency in, for example, the length of the metrics part.
12842 #------------------------------------------------------------------------------
12843 if ($all_metrics =~ /$zero_dot_at_end_regex/)
12847 #------------------------------------------------------------------------------
12848 # Somewhat overkill, but remove the leading "\" from the decimal separator
12849 # in the debug print since it is used for internal purposes only.
12850 #------------------------------------------------------------------------------
12851 my $decimal_point = $decimal_separator;
12852 $decimal_point =~ s/$backward_slash_regex//;
12853 my $txt = "all_metrics = $all_metrics ended with 0";
12854 $txt .= "$decimal_point ($decimal_separator)";
12855 gp_message
("debugXL", $subr_name, $txt);
12857 $all_metrics .= "ZZZ";
12860 $metrics_length = length ($all_metrics);
12861 $max_metrics_length = max
($max_metrics_length, $metrics_length);
12862 gp_message
("debugXL", $subr_name, "$routine all_metrics = $all_metrics metrics_length = $metrics_length");
12864 if ($full_hex_address =~ /$get_hex_address_regex/)
12866 $hex_address = "0x" . $2;
12869 push (@address_field, $hex_address);
12870 push (@metric_values, $all_metrics);
12872 #------------------------------------------------------------------------------
12873 # Record the function name "as is". Below we figure out what the final name
12874 # should be in case there are multiple occurrences of the same name.
12876 # The reason to decouple this is to avoid the code gets too complex here.
12877 #------------------------------------------------------------------------------
12878 push (@function_names, $routine);
12881 } #-- End of loop over the input lines
12883 #------------------------------------------------------------------------------
12884 # Store the maximum lengths for the header and metrics.
12885 #------------------------------------------------------------------------------
12886 gp_message
("debugXL", $subr_name, "final max_header_length = $max_header_length");
12887 gp_message
("debugXL", $subr_name, "final max_metrics_length = $max_metrics_length");
12889 $function_view_structure{"max header length"} = $max_header_length;
12890 $function_view_structure{"max metrics length"} = $max_metrics_length;
12892 #------------------------------------------------------------------------------
12893 # Determine the final name for the functions and set up the HTML block.
12894 #------------------------------------------------------------------------------
12895 my @final_html_function_block = ();
12896 my @function_index_list = ();
12898 #------------------------------------------------------------------------------
12899 # First, an index list is built. If we are to index the functions in order of
12900 # appearance in the function overview from 0 to n-1, the value of the array
12901 # for index "i" is the index into the large "function_info" structure. This
12902 # has the final name, the html function block, etc.
12903 #------------------------------------------------------------------------------
12905 #------------------------------------------------------------------------------
12906 ## TBD: Use get_index_function_info??!!
12907 #------------------------------------------------------------------------------
12908 for my $i (keys @function_names)
12910 #------------------------------------------------------------------------------
12911 # Get the function name and the address from the function overview. The
12912 # address is used to differentiate in case a function has multiple occurences.
12913 #------------------------------------------------------------------------------
12914 my $routine = $function_names[$i];
12915 my $current_address = $address_field[$i];
12917 my $found_a_match = $FALSE;
12918 my $final_function_name;
12921 #------------------------------------------------------------------------------
12922 # Check if there are duplicate entries for this function. If there are, use
12923 # the address to find the right match in the function_info structure.
12924 #------------------------------------------------------------------------------
12925 gp_message
("debugXL", $subr_name, "$routine: first check for multiple occurrences");
12926 if (exists ($g_multi_count_function{$routine}))
12928 gp_message
("debugXL", $subr_name, "$routine: occurrences = $g_function_occurrences{$routine}");
12929 for my $ref (keys @
{ $g_map_function_to_index{$routine} })
12931 my $ref_index = $g_map_function_to_index{$routine}[$ref];
12932 my $addr_offset = $function_info[$ref_index]{"addressobjtext"};
12933 #------------------------------------------------------------------------------
12934 # The address has the following format: 6:0x0003af50, but we only need the
12935 # part after the colon and remove the first part.
12936 #------------------------------------------------------------------------------
12937 $addr_offset =~ s/$get_addr_offset_regex//;
12939 gp_message
("debugXL", $subr_name, "$routine: ref_index = $ref_index");
12940 gp_message
("debugXL", $subr_name, "$routine: function_info[$ref_index]{'alt_name'} = $function_info[$ref_index]{'alt_name'}");
12941 gp_message
("debugXL", $subr_name, "$routine: addr_offset = $addr_offset");
12943 if ($addr_offset eq $current_address)
12944 #------------------------------------------------------------------------------
12945 # There is a match and we can store the index.
12946 #------------------------------------------------------------------------------
12948 $found_a_match = $TRUE;
12949 push (@function_index_list, $ref_index);
12956 #------------------------------------------------------------------------------
12957 # This is the easy case. There is only one index value. We do check if the
12958 # array element that contains it, exists. If this is not the case, something
12959 # has gone horribly wrong earlier and we need to bail out.
12960 #------------------------------------------------------------------------------
12961 if (defined ($g_map_function_to_index{$routine}[0]))
12963 $found_a_match = $TRUE;
12964 $ref_index = $g_map_function_to_index{$routine}[0];
12965 push (@function_index_list, $ref_index);
12966 my $final_function_name = $function_info[$ref_index]{"routine"};
12967 gp_message
("debugXL", $subr_name, "pushed single occurrence: ref_index = $ref_index final_function_name = $final_function_name");
12970 if (not $found_a_match)
12971 #------------------------------------------------------------------------------
12972 # This should not happen. All we can do is print an error message and stop.
12973 #------------------------------------------------------------------------------
12975 my $msg = "cannot find the index for $routine: found_a_match = ";
12976 $msg .= ($found_a_match == $TRUE) ?
"TRUE" : "FALSE";
12977 gp_message
("assertion", $subr_name, $msg);
12981 #------------------------------------------------------------------------------
12982 # The loop over all function names has completed and @function_index_list
12983 # contains the index values into @function_info for the functions.
12985 # All we now need to do is to retrieve the correct field(s) from the array.
12986 #------------------------------------------------------------------------------
12987 for my $i (keys @function_index_list)
12989 my $index_for_function = $function_index_list[$i];
12990 push (@final_html_function_block, $function_info[$index_for_function]{"html function block"});
12992 for my $i (keys @final_html_function_block)
12994 my $txt = "final_html_function_block[$i] = $final_html_function_block[$i]";
12995 gp_message
("debugXL", $subr_name, $txt);
12998 #------------------------------------------------------------------------------
12999 # Since the numbers are right aligned, we know that any difference between the
13000 # metric line length and the maximum must be caused by the first column. All
13001 # we need to do is to prepend spaces in case of a difference.
13003 # While we have the line with the metric values, we also replace ZZZ by 3
13005 #------------------------------------------------------------------------------
13006 for my $i (keys @metric_values)
13008 if (length ($metric_values[$i]) < $max_metrics_length)
13010 my $pad = $max_metrics_length - length ($metric_values[$i]);
13012 for my $s (1 .. $pad)
13014 $spaces .= " ";
13016 $metric_values[$i] = $spaces . $metric_values[$i];
13018 $metric_values[$i] =~ s/ZZZ/ /g;
13021 #------------------------------------------------------------------------------
13022 # Determine the column widths. The start and end index of the words in the
13023 # input line are stored in elements 0 and 1 of @word_index_values.
13025 # The assumption made is that the first digit of a metric value on the first
13026 # line is left # aligned with the header text. These are the Total values
13027 # and other than for some derived metrics, e.g. CPI, should be the largest.
13029 # The positions of the start of the value is what we should then use for the
13030 # word "(sort)" to start.
13034 # Excl. Excl. CPU Excl. Excl. Excl. Excl.
13035 # Total Cycles Instructions Last-Level IPC CPI
13036 # CPU sec. sec. Executed Cache Misses
13037 # 174.664 179.250 175838403203 1166209617 0.428 2.339
13038 #------------------------------------------------------------------------------
13042 my @index_values = ();
13043 my $index_values_ref;
13045 #------------------------------------------------------------------------------
13046 # Search for "Excl." in the top row. The metric values are aligned with this
13047 # word and we can use it to position "(sort)" in the last header line.
13049 # In @index_values, we store the position(s) of "Excl." in the header line.
13050 # If none can be found, an exception is raised because at least one should
13053 # TBD: Check if this can be done only once.
13054 #------------------------------------------------------------------------------
13055 my $target_keyword = "Excl.";
13057 ($foundit_ref, $index_values_ref) = find_keyword_in_string
(
13058 \
$remaining_part_header,
13061 $foundit = ${ $foundit_ref };
13062 @index_values = @
{ $index_values_ref };
13066 for my $i (keys @index_values)
13068 my $txt = "index_values[$i] = $index_values[$i]";
13069 gp_message
("debugXL", $subr_name, $txt);
13074 my $msg = "keyword $target_keyword not found in $remaining_part_header";
13075 gp_message
("assertion", $subr_name, $msg);
13078 #------------------------------------------------------------------------------
13079 # Compute the number of spaces we need to add between the "(sort)" strings.
13083 # 01234567890123456789
13089 # The number of spaces required is 14 - 6 = 8.
13091 # The number of spaces to be added is stored in @padding_values. These are
13092 # the spaces to be added before the occurrence of "(sort)". This is why the
13093 # first padding value is 0.
13094 #------------------------------------------------------------------------------
13096 #------------------------------------------------------------------------------
13097 # TBD: This needs to be done only once.
13098 #------------------------------------------------------------------------------
13099 my @padding_values = ();
13100 my $P_previous = 0;
13101 for my $i (keys @index_values)
13103 my $L = $index_values[$i];
13104 my $P = $L + length ("(sort)");
13105 my $pad_spaces = $L - $P_previous;
13107 push (@padding_values, $pad_spaces);
13112 for my $i (keys @padding_values)
13114 my $txt = "padding_values[$i] = $padding_values[$i]";
13115 gp_message
("debugXL", $subr_name, $txt);
13118 #------------------------------------------------------------------------------
13119 # Build up the sort line. Mark the current metric and make sure the line is
13120 # aligned with the header.
13121 #------------------------------------------------------------------------------
13122 my $sort_string = "(sort)";
13123 my $length_sort_string = length ($sort_string);
13124 my $sort_line = "";
13125 my @active_metrics = split (":", $summary_metrics);
13126 for my $i (0 .. $number_of_metrics-1)
13128 my $pad = $padding_values[$i];
13129 my $metric_value = $active_metrics[$i];
13132 for my $s (1 .. $pad)
13134 $spaces .= " ";
13137 gp_message
("debugXL", $subr_name, "i = $i metric_value = $metric_value pad = $pad");
13139 if ($metric_value eq $exp_type)
13140 #------------------------------------------------------------------------------
13141 # The current metric should have a different background color.
13142 #------------------------------------------------------------------------------
13144 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
13145 "." . $metric_value . ".html' style='background-color:" .
13146 $g_html_color_scheme{"background_selected_sort"} .
13147 "\'><b>(sort)</b></a>";
13149 elsif (($exp_type eq "functions") and ($metric_value eq $g_first_metric))
13150 #------------------------------------------------------------------------------
13151 # Set the background color for the sort metric in the main function overview.
13152 #------------------------------------------------------------------------------
13154 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
13155 "." . $metric_value . ".html' style='background-color:" .
13156 $g_html_color_scheme{"background_selected_sort"} .
13157 "'><b>(sort)</b></a>";
13160 #------------------------------------------------------------------------------
13161 # Do not set a specific background for all other metrics.
13162 #------------------------------------------------------------------------------
13164 $sort_string = "<a href=\'" . $g_html_base_file_name{"function_view"} .
13165 "." . $metric_value . ".html'>(sort)</a>";
13168 #------------------------------------------------------------------------------
13169 # Prepend the spaces to ensure correct alignment with the rest of the header.
13170 #------------------------------------------------------------------------------
13171 $sort_line .= $spaces . $sort_string;
13174 push (@header_lines, $sort_line);
13176 #------------------------------------------------------------------------------
13177 # Print the final results for the header and metrics.
13178 #------------------------------------------------------------------------------
13179 for my $i (keys @header_lines)
13181 gp_message
("debugXL", $subr_name, "header_lines[$i] = $header_lines[$i]");
13183 for my $i (keys @metric_values)
13185 gp_message
("debugXL", $subr_name, "metric_values[$i] = $metric_values[$i]");
13188 #------------------------------------------------------------------------------
13189 # Construct the lines for the function overview.
13191 # TBD: We could eliminate two structures here because metric_values and
13192 # final_html_function_block are only copied and the result stored.
13193 #------------------------------------------------------------------------------
13194 for my $i (keys @function_names)
13196 push (@metrics_part, $metric_values[$i]);
13197 push (@function_view_array, $final_html_function_block[$i]);
13200 for my $i (0 .. $#function_view_array)
13202 my $msg = "function_view_array[$i] = $function_view_array[$i]";
13203 gp_message
("debugXL", $subr_name, $msg);
13205 #------------------------------------------------------------------------------
13206 # Element "function table" contains the array with all the function view data.
13207 #------------------------------------------------------------------------------
13208 $function_view_structure{"header"} = [@header_lines];
13209 $function_view_structure{"metrics part"} = [@metrics_part];
13210 $function_view_structure{"function table"} = [@function_view_array];
13212 return (\
%function_view_structure);
13214 } #-- End of subroutine process_function_overview
13216 #------------------------------------------------------------------------------
13218 #------------------------------------------------------------------------------
13219 sub process_metrics
13221 my $subr_name = get_my_name
();
13223 my ($input_string, $sort_fields_ref, $metric_description_ref, $ignored_metrics_ref) = @_;
13225 my @sort_fields = @
{ $sort_fields_ref };
13226 my %metric_description = %{ $metric_description_ref };
13227 my %ignored_metrics = %{ $ignored_metrics_ref };
13229 my $outputdir = append_forward_slash
($input_string);
13230 my $LANG = $g_locale_settings{"LANG"};
13232 my $metric_comment;
13234 my ($imetricn,$outfile);
13235 my ($html_metrics_record,$imetric,$metric);
13237 $html_metrics_record =
13238 "<!doctype html public \"-//w3c//dtd html 3.2//EN\">\n<html lang=\"$LANG\">\n<head>\n" .
13239 "<meta http-equiv=\"content-type\" content=\"text/html; charset=iso-8859-1\">\n" .
13240 "<title>Function Metrics</title></head><body lang=\"$LANG\" bgcolor=".$g_html_color_scheme{"background_color_page"}."<pre>\n";
13242 $outfile = $outputdir . "metrics.html";
13244 open (METRICSOUT
, ">", $outfile)
13245 or die ("$subr_name - unable to open file $outfile for writing - '$!'");
13246 gp_message
("debug", $subr_name, "opened file $outfile for writing");
13248 for $metric (@sort_fields)
13250 $max_len = max
($max_len, length ($metric));
13251 gp_message
("debug", $subr_name, "sort_fields: metric = $metric max_len = $max_len");
13255 # for $imetric (@IMETRICS)
13256 for $imetric (keys %ignored_metrics)
13258 $max_len = max
($max_len, length ($imetric));
13259 gp_message
("debug", $subr_name, "ignored_metrics imetric = $imetric max_len = $max_len");
13264 gp_message
("debug", $subr_name, "max_len = $max_len");
13266 $html_metrics_record .= "<p style=\"font-size:14px;color:red\"> Metrics used (".($#sort_fields + 1).")\n</p><p style=\"font-size:14px\">";
13267 for $metric (@sort_fields)
13269 my $description = ${ retrieve_metric_description
(\
$metric, \
%metric_description) };
13270 gp_message
("debug", $subr_name, "handling metric metric = $metric->$description");
13271 $html_metrics_record .= " $metric".(' ' x
($max_len - length ($metric)))."$description\n";
13274 # $imetricn = scalar (keys %IMETRICS);
13275 $imetricn = scalar (keys %ignored_metrics);
13278 $html_metrics_record .= "</p><p style=\"font-size:14px;color:red\"> Metrics ignored ($imetricn)\n</p><p style=\"font-size:14px\">";
13279 # for $imetric (sort keys %IMETRICS){
13280 for $imetric (sort keys %ignored_metrics)
13282 $metric_comment = "(inclusive, exclusive, and percentages)";
13283 $html_metrics_record .= " $imetric".(' ' x
($max_len - length ($imetric))).$metric_comment."\n";
13284 gp_message
("debug", $subr_name, "handling metric imetric = $imetric $metric_comment");
13288 print METRICSOUT
$html_metrics_record;
13289 print METRICSOUT
$g_html_credits_line;
13290 close (METRICSOUT
);
13292 gp_message
("debug", $subr_name, "closed metrics file $outfile");
13296 } #-- End of subroutine process_metrics
13298 #------------------------------------------------------------------------------
13300 #------------------------------------------------------------------------------
13301 sub process_metrics_data
13303 my $subr_name = get_my_name
();
13305 my ($outfile1, $outfile2, $ignored_metrics_ref) = @_;
13307 my %ignored_metrics = %{ $ignored_metrics_ref };
13309 my %metric_value = ();
13310 my %metric_description = ();
13311 my %metric_found = ();
13314 my $system_metrics;
13318 my $metric_visibility;
13324 my $summary_metrics;
13325 my $detail_metrics;
13326 my $detail_metrics_system;
13329 if ($g_user_settings{"default_metrics"}{"current_value"} eq "off")
13331 gp_message
("debug", $subr_name, "g_user_settings{default_metrics}{current_value} = " . $g_user_settings{"default_metrics"}{"current_value"});
13334 $summary_metrics='';
13335 $detail_metrics='';
13336 $detail_metrics_system='';
13337 $call_metrics = '';
13342 my ($last_metric,$metric,$value,$i,$r);
13344 open (METRICTOTALS
, "<", $outfile2)
13345 or die ("Unable to open metric value data file $outfile2 for reading - '$!'");
13346 gp_message
("debug", $subr_name, "opened $outfile2 to parse metric value data");
13348 #------------------------------------------------------------------------------
13349 # Below an example of the file that has just been opened. The lines I marked
13350 # with a * has been wrapped by my for readability. This is not the case in the
13351 # file, but makes for a really long line.
13353 # Also, the data comes from one PC experiment and two HWC experiments.
13354 #------------------------------------------------------------------------------
13356 # Exclusive Total CPU Time: 32.473 (100.0%)
13357 # Inclusive Total CPU Time: 32.473 (100.0%)
13358 # Exclusive CPU Cycles: 23.586 (100.0%)
13359 # " count: 47054706905
13360 # Inclusive CPU Cycles: 23.586 (100.0%)
13361 # " count: 47054706905
13362 # Exclusive Instructions Executed: 54417033412 (100.0%)
13363 # Inclusive Instructions Executed: 54417033412 (100.0%)
13364 # Exclusive Last-Level Cache Misses: 252730685 (100.0%)
13365 # Inclusive Last-Level Cache Misses: 252730685 (100.0%)
13366 # * Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle:
13367 # * Exclusive Cycles Per Instruction:
13368 # * Inclusive Cycles Per Instruction:
13370 # PC Address: 1:0x00000000
13371 # Source File: (unknown)
13372 # Object File: (unknown)
13373 # Load Object: <Total>
13376 #------------------------------------------------------------------------------
13378 while (<METRICTOTALS
>)
13380 $metricdata = $_; chomp ($metricdata);
13381 gp_message
("debug", $subr_name, "file metrictotals: $metricdata");
13383 #------------------------------------------------------------------------------
13384 # Ignoring whitespace, search for any line with a ":" in it, followed by
13385 # a number with or without a dot. So, an integer or floating-point number.
13386 #------------------------------------------------------------------------------
13387 if ($metricdata =~ /\s*(.*):\s+(\d+\.*\d*)/)
13389 gp_message
("debug", $subr_name, " candidate => $metricdata");
13392 if ( ($metric eq "PC Address") or ($metric eq "Size"))
13394 gp_message
("debug", $subr_name, " skipped => $metric $value");
13397 gp_message
("debug", $subr_name, " proceed => $metric $value");
13398 if ($metric eq '" count')
13399 #------------------------------------------------------------------------------
13400 # Hardware counter experiments have this info. Note that this line is not the
13401 # first one to be encountered, so $last_metric has been defined already.
13402 #------------------------------------------------------------------------------
13404 $metric = $last_metric." Count"; # we presume .......
13405 gp_message
("debug", $subr_name, "last_metric = $last_metric metric = $metric");
13407 $i=index ($metricdata,":");
13408 $r=rindex ($metricdata,":");
13409 gp_message
("debug", $subr_name, "metricdata = $metricdata => i = $i r = $r");
13412 if ($value > 0) # Not interested in metrics contributing zero
13414 $metric_value{$metric} = $value;
13415 gp_message
("debug", $subr_name, "archived metric_value{$metric} = $metric_value{$metric}");
13416 # e.g. $metric_value{Exclusive Total Thread Time} = 302.562
13417 # e.g. $metric_value{Exclusive Instructions Executed} = 2415126222484
13421 #------------------------------------------------------------------------------
13422 # TBD This code deals with an old bug and may be removed.
13423 #------------------------------------------------------------------------------
13424 { # er_print bug - e.g.
13425 # Exclusive Instructions Per Cycle: Inclusive Instructions Per Cycle: Exclusive Cycles Per Instruction: Inclusive Cycles Per Instruction: Exclusive OpenMP Work Time: 162.284 (100.0%)
13426 gp_message
("debug", $subr_name, "metrictotals odd line:->$metricdata<-");
13427 $r=rindex ($metricdata,":",$r-1);
13430 gp_message
("debug", $subr_name, "metrictotals odd line ignored<-");
13431 $last_metric = "foo";
13434 my ($good_part)=substr ($metricdata,$r+1);
13435 if ($good_part =~ /\s*(.*):\s+(\d+\.*\d*)/)
13439 if ($value>0) # Not interested in metrics contributing zero
13441 $metric_value{$metric} = $value;
13442 my $msg = "metrictotals odd line rescued '$metric'=$value";
13443 gp_message
("debug", $subr_name, $msg);
13447 #------------------------------------------------------------------------------
13448 # Preserve the current metric.
13449 #------------------------------------------------------------------------------
13450 $last_metric = $metric;
13453 close (METRICTOTALS
);
13456 if (scalar (keys %metric_value) == 0)
13457 #------------------------------------------------------------------------------
13458 # If we have no metrics > 0, fudge a "Exclusive Total CPU Time", else we
13461 # TBD: See if this can be handled differently.
13462 #------------------------------------------------------------------------------
13464 $metric_value{"Exclusive Total CPU Time"} = 0;
13465 gp_message
("debug", $subr_name, "no metrics found and a stub was added");
13468 for my $metric (sort keys %metric_value)
13470 gp_message
("debug", $subr_name, "Stored metric_value{$metric} = $metric_value{$metric}");
13473 gp_message
("debug", $subr_name, "proceed to process file $outfile1");
13475 #------------------------------------------------------------------------------
13476 # Open and process the metrics file.
13477 #------------------------------------------------------------------------------
13478 open (METRICS
, "<", $outfile1)
13479 or die ("Unable to open metrics file $outfile1: '$!'");
13480 gp_message
("debug", $subr_name, "opened file $outfile1 for reading");
13482 #------------------------------------------------------------------------------
13483 # Parse the file. This is a typical example:
13490 # Current metrics: e.totalcpu:i.totalcpu:e.cycles:e+insts:e+llm:name
13491 # Current Sort Metric: Exclusive Total CPU Time ( e.totalcpu )
13492 # Available metrics:
13493 # Exclusive Total CPU Time: e.%totalcpu
13494 # Inclusive Total CPU Time: i.%totalcpu
13495 # Exclusive CPU Cycles: e.+%cycles
13496 # Inclusive CPU Cycles: i.+%cycles
13497 # Exclusive Instructions Executed: e+%insts
13498 # Inclusive Instructions Executed: i+%insts
13499 # Exclusive Last-Level Cache Misses: e+%llm
13500 # Inclusive Last-Level Cache Misses: i+%llm
13501 # Exclusive Instructions Per Cycle: e+IPC
13502 # Inclusive Instructions Per Cycle: i+IPC
13503 # Exclusive Cycles Per Instruction: e+CPI
13504 # Inclusive Cycles Per Instruction: i+CPI
13506 # PC Address: address
13508 #------------------------------------------------------------------------------
13512 chomp ($metric_line);
13514 gp_message
("debug", $subr_name, "processing line $metric_line");
13515 #------------------------------------------------------------------------------
13516 # The original regex has bugs because the line should not be allowed to start
13517 # with a ":". So this is wrong:
13518 # if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/))
13521 # if (($metric =~ /\s*(.+):\s+(\S)((\.\S+)|(\+\S+))/) and !($metric =~/^Current/))
13523 # In general, this regex has some potential issues and has been replaced by
13524 # the one shown below.
13526 # We select a line that does not start with "Current" and aside from whitespace
13527 # starts with anything (although it should be a string with words only),
13528 # followed by whitespace and either an "e" or "i". This is called the "flavor"
13529 # and is followed by a visibility marker (.,+,%, or !) and a metric name.
13530 #------------------------------------------------------------------------------
13531 # Ruud if (($metric =~ /\s*(.*):\s+(\S)((\.\S+)|(\+\S+))/) && !($metric =~/^Current/)){
13533 ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_text) =
13534 extract_metric_specifics
($metric_line);
13536 # if (($metric_line =~ /\s*(.+):\s+([ei])([\.\+%]+)(\S*)/) and !($metric_line =~/^Current/))
13537 if ($metric_spec eq "skipped")
13539 gp_message
("debug", $subr_name, "skipped line: $metric_line");
13543 gp_message
("debug", $subr_name, "line of interest: $metric_line");
13545 $metric_found{$metric_spec} = 1;
13547 if ($g_user_settings{"ignore_metrics"}{"defined"})
13549 gp_message
("debug", $subr_name, "check for $metric_spec");
13550 if (exists ($ignored_metrics{$metric_name}))
13552 gp_message
("debug", $subr_name, "user asked to ignore metric $metric_name");
13557 #------------------------------------------------------------------------------
13558 # This metric is not on the ignored list and qualifies, so store it.
13559 #------------------------------------------------------------------------------
13560 $metric_description{$metric_spec} = $metric_text;
13562 # TBD: add for other visibilities too, like +
13563 gp_message
("debug", $subr_name, "stored $metric_description{$metric_spec} = $metric_description{$metric_spec}");
13565 if ($metric_flavor ne "e")
13567 gp_message
("debug", $subr_name, "metric $metric_spec is ignored");
13570 #------------------------------------------------------------------------------
13571 # Only the exclusive metrics are shown.
13572 #------------------------------------------------------------------------------
13574 gp_message
("debug", $subr_name, "metric $metric_spec ($metric_text) is considered");
13576 if ($metric_spec =~ /user/)
13578 $user_metrics = $TRUE;
13579 gp_message
("debug", $subr_name, "m: user_metrics set to TRUE");
13581 elsif ($metric_spec =~ /system/)
13583 $system_metrics = $TRUE;
13584 gp_message
("debug", $subr_name, "m: system_metrics set to TRUE");
13586 elsif ($metric_spec =~ /wall/)
13588 $wall_metrics = $TRUE;
13589 gp_message
("debug", $subr_name, "m: wall_metrics set to TRUE");
13591 #------------------------------------------------------------------------------
13592 # TBD I don't see why these need to be skipped. Also, should be totalcpu.
13593 #------------------------------------------------------------------------------
13594 elsif (($metric_spec =~ /^e\.total$/) or ($metric_spec =~/^e\.total_cpu$/))
13596 # skip total thread time and total CPU time
13597 gp_message
("debug", $subr_name, "m: skip above");
13599 elsif (defined ($metric_value{$metric_text}))
13601 gp_message
("debug", $subr_name, "Total attributed to this metric metric_value{$metric_text} = $metric_value{$metric_text}");
13602 if ($summary_metrics ne '')
13604 $summary_metrics = $summary_metrics.':'.$metric_spec;
13605 gp_message
("debug", $subr_name, "updated summary_metrics = $summary_metrics - 1");
13606 if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/)
13608 $detail_metrics = $detail_metrics.':'.$metric_spec;
13609 gp_message
("debug", $subr_name, "updated m:detail_metrics=$detail_metrics - 1");
13610 $detail_metrics_system = $detail_metrics_system.':'.$metric_spec;
13611 gp_message
("debug", $subr_name, "updated m:detail_metrics_system=$detail_metrics_system - 1");
13615 gp_message
("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system");
13620 $summary_metrics = $metric_spec;
13621 gp_message
("debug", $subr_name, "initialized summary_metrics = $summary_metrics - 2");
13622 if ($metric_spec !~ /\.wait$|\.ulock$|\.text$|\.data$|\.owait$|total$|mpiwork$|mpiwait$|ompwork$|ompwait$/)
13624 $detail_metrics = $metric_spec;
13625 gp_message
("debug", $subr_name, "m:detail_metrics=$detail_metrics - 2");
13626 $detail_metrics_system = $metric_spec;
13627 gp_message
("debug", $subr_name, "m:detail_metrics_system=$detail_metrics_system - 2");
13631 gp_message
("debug", $subr_name, "m: no want above metric for detail_metrics or detail_metrics_system");
13634 gp_message
("debug", $subr_name, " metric $metric_spec added");
13638 gp_message
("debug", $subr_name, "m: no want above metric was a 0 total");
13646 if ($wall_metrics > 0)
13648 gp_message
("debug", $subr_name,"m:wall_metrics set adding to summary_metrics");
13649 $summary_metrics = "e.wall:".$summary_metrics;
13650 gp_message
("debug", $subr_name,"m:summary_metrics=$summary_metrics - 3");
13653 if ($system_metrics > 0)
13655 gp_message
("debug", $subr_name,"m:system_metrics set adding to summary_metrics,call_metrics and detail_metrics_system");
13656 $summary_metrics = "e.system:".$summary_metrics;
13657 $call_metrics = "i.system:".$call_metrics;
13658 $detail_metrics_system ='e.system:'.$detail_metrics_system;
13660 gp_message
("debug", $subr_name,"m:summary_metrics=$summary_metrics - 4");
13661 gp_message
("debug", $subr_name,"m:call_metrics=$call_metrics");
13662 gp_message
("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 3");
13666 #------------------------------------------------------------------------------
13667 # TBD: e.user and i.user do not always exist!!
13668 #------------------------------------------------------------------------------
13670 if ($user_metrics > 0)
13672 gp_message
("debug", $subr_name,"m:user_metrics set adding to summary_metrics,detail_metrics,detail_metrics_system and call_metrics");
13673 # Ruud if (!exists ($IMETRICS{"i.user"})){
13674 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"}))
13676 $summary_metrics = "e.user:".$summary_metrics;
13680 $summary_metrics = "e.user:i.user:".$summary_metrics;
13682 $detail_metrics = "e.user:".$detail_metrics;
13683 $detail_metrics_system = "e.user:".$detail_metrics_system;
13685 gp_message
("debug", $subr_name,"m:summary_metrics=$summary_metrics - 5");
13686 gp_message
("debug", $subr_name,"m:detail_metrics=$detail_metrics - 3");
13687 gp_message
("debug", $subr_name,"m:detail_metrics_system=$detail_metrics_system - 4");
13689 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{"user"}))
13691 $call_metrics = "a.user:".$call_metrics;
13695 $call_metrics = "a.user:i.user:".$call_metrics;
13697 gp_message
("debug", $subr_name,"m:call_metrics=$call_metrics - 2");
13700 if ($call_metrics eq "")
13702 $call_metrics = $detail_metrics;
13704 gp_message
("debug", $subr_name,"m:call_metrics is not set, setting it to detail_metrics ");
13705 gp_message
("debug", $subr_name,"m:call_metrics=$call_metrics - 3");
13708 for my $metric (sort keys %ignored_metrics)
13710 if ($ignored_metrics{$metric})
13712 gp_message
("debug", $subr_name, "active metric, but ignored: $metric");
13717 return (\
%metric_value, \
%metric_description, \
%metric_found, $user_metrics, $system_metrics, $wall_metrics,
13718 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics);
13720 } #-- End of subroutine process_metrics_data
13722 #------------------------------------------------------------------------------
13723 # Process source lines that are not part of the target function.
13725 # Generate straightforward HTML, but define an anchor based on the source line
13726 # number in the list.
13727 #------------------------------------------------------------------------------
13728 sub process_non_target_source
13730 my $subr_name = get_my_name
();
13732 my ($start_scan, $end_scan,
13733 $src_times_regex, $function_regex, $number_of_metrics,
13734 $file_contents_ref, $modified_html_ref) = @_;
13736 my @file_contents = @
{ $file_contents_ref };
13737 my @modified_html = @
{ $modified_html_ref };
13738 my $colour_code_line = $FALSE;
13743 #------------------------------------------------------------------------------
13744 # Main loop to parse all of the source code and take action as needed.
13745 #------------------------------------------------------------------------------
13746 for (my $line_no=$start_scan; $line_no <= $end_scan; $line_no++)
13748 $input_line = $file_contents[$line_no];
13750 #------------------------------------------------------------------------------
13751 # Generate straightforward HTML, but define an anchor based on the source line
13752 # number in the list.
13753 #------------------------------------------------------------------------------
13754 $line_id = extract_source_line_number
($src_times_regex,
13756 $number_of_metrics,
13759 if ($input_line =~ /$function_regex/)
13761 $colour_code_line = $TRUE;
13764 #------------------------------------------------------------------------------
13765 # We need to replace the "<" symbol in the code by "<".
13766 #------------------------------------------------------------------------------
13767 $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
13769 #------------------------------------------------------------------------------
13771 #------------------------------------------------------------------------------
13772 $modified_line = "<a id=\"line_" . $line_id . "\"></a>";
13775 if ($colour_code_line)
13777 my $boldface = $TRUE;
13778 $coloured_line = color_string
(
13781 $g_html_color_scheme{"non_target_function_name"});
13782 $colour_code_line = $FALSE;
13783 $modified_line .= "$coloured_line";
13787 $modified_line .= "$input_line";
13789 gp_message
("debugXL", $subr_name, " $line_no : modified_line = $modified_line");
13790 push (@modified_html, $modified_line);
13793 return (\
@modified_html);
13795 } #-- End of subroutine process_non_target_source
13797 #------------------------------------------------------------------------------
13798 # This function scans the configuration file and adapts the internal settings
13801 # Errors are stored during the parsing and processing phase. They are printed
13802 # at the end and sorted by line number.
13805 # TBD: Does not yet use the warnings/error system. This needs to be fixed.
13806 #------------------------------------------------------------------------------
13807 sub process_rc_file
13809 my $subr_name = get_my_name
();
13811 my ($rc_file_name, $rc_file_paths_ref) = @_;
13813 #------------------------------------------------------------------------------
13814 # Local structures.
13815 #------------------------------------------------------------------------------
13816 # Stores the values extracted from the config file:
13817 my %rc_settings_user = ();
13818 my %error_and_warning_msgs = ();
13819 my @rc_file_paths = ();
13828 my $no_of_arguments;
13829 my $number_of_fields;
13830 my $number_of_paths;
13831 my $parse_errors; #-- Count the number of errors
13832 my $parse_warnings; #-- Count the number of errors
13834 my $rc_config_file;
13839 @rc_file_paths = @
{$rc_file_paths_ref};
13840 $number_of_paths = scalar (@rc_file_paths);
13842 if ($number_of_paths == 0)
13843 #------------------------------------------------------------------------------
13844 # This should not happen, but is a good safety net to add.
13845 #------------------------------------------------------------------------------
13847 my $msg = "search path list is empty";
13848 gp_message
("assertion", $subr_name, $msg);
13851 #------------------------------------------------------------------------------
13852 # Check for the presence of a configuration file.
13853 #------------------------------------------------------------------------------
13854 $msg = "number_of_paths = $number_of_paths rc_file_paths = @rc_file_paths";
13855 gp_message
("debug", $subr_name, $msg);
13857 $rc_file_found = $FALSE;
13858 for my $path_name (@rc_file_paths)
13860 $rc_config_file = $path_name . "/" . $rc_file_name;
13861 $msg = "looking for configuration file " . $rc_config_file;
13862 gp_message
("debug", $subr_name, $msg);
13863 if (-f
$rc_config_file)
13865 $msg = "found configuration file " . $rc_config_file;
13866 gp_message
("debug", $subr_name, $msg);
13867 $rc_file_found = $TRUE;
13872 if (not $rc_file_found)
13873 #------------------------------------------------------------------------------
13874 # There is no configuration file and we can skip this subroutine.
13875 #------------------------------------------------------------------------------
13877 $msg = "configuration file $rc_file_name not found";
13878 gp_message
("verbose", $subr_name, $msg);
13883 $msg = "unable to open file $rc_config_file for reading:";
13884 open (GP_DISPLAY_HTML_RC
, "<", "$rc_config_file")
13885 or die ($subr_name . " - " . $msg . " " . $!);
13886 #------------------------------------------------------------------------------
13887 # The configuration file has been opened for reading.
13888 #------------------------------------------------------------------------------
13889 $msg = "file $rc_config_file has been opened for reading";
13890 gp_message
("debug", $subr_name, $msg);
13893 $msg = "found configuration file $rc_config_file";
13894 gp_message
("verbose", $subr_name, $msg);
13895 $msg = "processing configuration file " . $rc_config_file;
13896 gp_message
("debug", $subr_name, $msg);
13898 #------------------------------------------------------------------------------
13899 # Here we scan the configuration file for the settings.
13901 # A setting consists of a keyword, optionally followed by a value. It is
13902 # optional because not all keywords may require a value.
13904 # At the end of this block, all keyword/value pairs are stored in a hash.
13906 # We do not yet check for the validity of these pairs. This is done next.
13908 # The original code had this all integrated, but it made the code very
13909 # complex with deeply nested if-statements. The flow was also hard to follow.
13910 #------------------------------------------------------------------------------
13912 $parse_warnings = 0;
13914 while (my $line = <GP_DISPLAY_HTML_RC
>)
13919 gp_message
("debug", $subr_name, "read input line = $line");
13921 #------------------------------------------------------------------------------
13922 # Ignore a line with whitespace only
13923 #------------------------------------------------------------------------------
13924 if ($line =~ /^\s*$/)
13926 gp_message
("debug", $subr_name, "ignored a line with whitespace");
13930 #------------------------------------------------------------------------------
13931 # Ignore a comment line, defined by starting with a "#", possibly prepended by
13933 #------------------------------------------------------------------------------
13934 if ($line =~ /^\s*\#/)
13936 gp_message
("debug", $subr_name, "ignored a full comment line");
13940 #------------------------------------------------------------------------------
13941 # Split the input line using the "#" symbol as a separator. We have already
13942 # handled the case of an isolated comment line, so there may only be an
13943 # embedded comment.
13945 # Regardless of this, we are only interested in the first part.
13946 #------------------------------------------------------------------------------
13947 @split_line = split ("#", $line);
13949 for my $i (@split_line)
13951 gp_message
("debug", $subr_name, "elements after split of line: $i");
13954 $first_part = $split_line[0];
13955 gp_message
("debug", $subr_name, "relevant part = $first_part");
13957 if ($first_part =~ /[&\^\*\@\$]+/)
13958 #------------------------------------------------------------------------------
13959 # The &, ^, *, @ and $ symbols should not occur. If they do, we flag an error
13960 # an fetch the next line.
13961 #------------------------------------------------------------------------------
13964 $msg = "non-supported character(s) (\&,\^,\*,\@,\$) found: $line";
13965 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg;
13969 #------------------------------------------------------------------------------
13970 # Split the first part on whitespace and verify the number of fields to be
13971 # valid. Although we currently only have keywords with a value, a keyword
13972 # without value is supported to.
13974 # If the number of fields is valid, the keyword and value are stored. In case
13975 # of a single field, the value is assigned a special string.
13977 # Although this situation should not occur, we do abort if something unexpected
13978 # is encountered here.
13979 #------------------------------------------------------------------------------
13981 @my_fields = split (/\s/, $split_line[0]);
13983 $number_of_fields = scalar (@my_fields);
13984 $msg = "number of fields = " . $number_of_fields;
13985 gp_message
("debug", $subr_name, $msg);
13988 if ($number_of_fields ge 3)
13989 #------------------------------------------------------------------------------
13990 # This is not supported.
13991 #------------------------------------------------------------------------------
13994 $msg = "more than 2 fields found: $first_part";
13995 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg;
13998 elsif ($number_of_fields eq 2)
14000 $rc_keyword = $my_fields[0];
14001 $rc_value = $my_fields[1];
14003 elsif ($number_of_fields eq 1)
14005 $rc_keyword = $my_fields[0];
14006 $rc_value = "the_field_is_empty";
14010 $msg = "[line $line_number] $rc_config_file -";
14011 $msg .= " number of fields = $number_of_fields";
14012 gp_message
("assertion", $subr_name, $msg);
14015 #------------------------------------------------------------------------------
14016 # Store the keyword, value and line number.
14017 #------------------------------------------------------------------------------
14018 if (exists ($rc_settings_user{$rc_keyword}))
14021 my $prev_value = $rc_settings_user{$rc_keyword}{"value"};
14022 my $prev_line_number = $rc_settings_user{$rc_keyword}{"line_no"};
14023 if ($rc_value ne $prev_value)
14025 $msg = "option $rc_keyword previously set at line";
14026 $msg .= " $prev_line_number: new value '$rc_value'";
14027 $msg .= " ' overrides '$prev_value'";
14031 $msg = "option $rc_keyword previously set to the same value";
14032 $msg .= " at line $prev_line_number";
14034 $error_and_warning_msgs{"warning"}{$line_number}{"message"} = $msg;
14036 $rc_settings_user{$rc_keyword}{"value"} = $rc_value;
14037 $rc_settings_user{$rc_keyword}{"line_no"} = $line_number;
14039 gp_message
("debug", $subr_name, "stored keyword = $rc_keyword");
14040 gp_message
("debug", $subr_name, "stored value = $rc_value");
14041 gp_message
("debug", $subr_name, "stored line number = $line_number");
14044 #------------------------------------------------------------------------------
14045 # Completed the parsing of the configuration file. It can be closed.
14046 #------------------------------------------------------------------------------
14047 close (GP_DISPLAY_HTML_RC
);
14049 #------------------------------------------------------------------------------
14050 # Print the raw input as just collected from the configuration file.
14051 #------------------------------------------------------------------------------
14052 gp_message
("debug", $subr_name, "contents of %rc_settings_user:");
14053 for my $keyword (keys %rc_settings_user)
14055 my $key_value = $rc_settings_user{$keyword}{"value"};
14056 $msg = "keyword = " . $keyword . " value = " . $key_value;
14057 gp_message
("debug", $subr_name, $msg);
14060 for my $rc_keyword (keys %g_user_settings)
14062 for my $fields (keys %{ $g_user_settings{$rc_keyword} })
14064 $msg = "before config file: $rc_keyword $fields =";
14065 $msg .= " " . $g_user_settings{$rc_keyword}{$fields};
14066 gp_message
("debug", $subr_name, $msg);
14070 #------------------------------------------------------------------------------
14071 # We are almost done. Check for all keywords found whether they are valid.
14072 # Also verify that the corresponding value is valid.
14074 # Update the g_user_settings table if everything is okay.
14075 #------------------------------------------------------------------------------
14077 for my $rc_keyword (keys %rc_settings_user)
14079 my $rc_value = $rc_settings_user{$rc_keyword}{"value"};
14081 if (exists ( $g_user_settings{$rc_keyword}))
14084 #------------------------------------------------------------------------------
14085 # This is a supported keyword. There are two more things left to do:
14086 # - Check how many values it requires (currently exactly one is supported)
14087 # - Is the value a valid number or string?
14088 #------------------------------------------------------------------------------
14089 $no_of_arguments = $g_user_settings{$rc_keyword}{"no_of_arguments"};
14091 if ($no_of_arguments eq 1)
14093 my $input_value = $rc_value;
14094 if ($input_value ne "the_field_is_empty")
14096 #------------------------------------------------------------------------------
14097 # So far, so good. We only need to check if the value is valid for the keyword.
14098 #------------------------------------------------------------------------------
14100 my $data_type = $g_user_settings{$rc_keyword}{"data_type"};
14102 verify_if_input_is_valid
($input_value, $data_type);
14103 #------------------------------------------------------------------------------
14104 # Check if the value is valid.
14105 #------------------------------------------------------------------------------
14108 $g_user_settings{$rc_keyword}{"current_value"} =
14110 $g_user_settings{$rc_keyword}{"defined"} = $TRUE;
14115 $line_number = $rc_settings_user{$rc_keyword}{"line_no"};
14116 $msg = "input value '$input_value' for keyword";
14117 $msg .= " $rc_keyword is not valid";
14118 $error_and_warning_msgs{"error"}{$line_number}{"message"}
14124 #------------------------------------------------------------------------------
14125 # This keyword requires a value, but none has been found.
14126 #------------------------------------------------------------------------------
14129 $line_number = $rc_settings_user{$rc_keyword}{"line_no"};
14130 $msg = "missing value for keyword '$rc_keyword'";
14131 $error_and_warning_msgs{"error"}{$line_number}{"message"}
14136 elsif ($no_of_arguments eq 0)
14137 #------------------------------------------------------------------------------
14138 # Currently a theoretical scenario since all commands require a value, but in
14139 # case this is no longer true, we need to at least flag the fact the user set
14141 #------------------------------------------------------------------------------
14143 $g_user_settings{$rc_keyword}{"defined"} = $TRUE;
14146 #------------------------------------------------------------------------------
14147 # The code is not prepared for the situation one command has multiple values,
14148 # but this situation should never occur. Still it won't hurt to add a check.
14149 #------------------------------------------------------------------------------
14151 my $msg = "cannot handle $no_of_arguments in the input";
14152 gp_message
("assertion", $subr_name, $msg);
14156 #------------------------------------------------------------------------------
14157 # A non-valid keyword is found. This is flagged as an error.
14158 #------------------------------------------------------------------------------
14161 $line_number = $rc_settings_user{$rc_keyword}{"line_no"};
14162 $msg = "keyword $rc_keyword is not supported";
14163 $error_and_warning_msgs{"error"}{$line_number}{"message"} = $msg;
14166 for my $rc_keyword (keys %g_user_settings)
14168 for my $fields (keys %{ $g_user_settings{$rc_keyword} })
14170 $msg = "after config file: $rc_keyword $fields =";
14171 $msg .= " " . $g_user_settings{$rc_keyword}{$fields};
14172 gp_message
("debug", $subr_name, $msg);
14175 print_table_user_settings
("debug", "upon the return from $subr_name");
14177 if ( ($parse_errors == 0) and ($parse_warnings == 0) )
14179 $msg = "successfully parsed and processed the configuration file";
14180 gp_message
("verbose", $subr_name, $msg);
14184 if ($parse_errors > 0)
14186 my $plural_or_single = ($parse_errors > 1) ?
"errors" : "error";
14187 $msg = $g_error_keyword . "found $parse_errors fatal";
14188 $msg .= " " . $plural_or_single . " in the configuration file:";
14189 gp_message
("debug", $subr_name, $msg);
14190 #------------------------------------------------------------------------------
14191 # Sort the hash keys, the line numbers, alphabetically and print the
14192 # corresponding error messages.
14193 #------------------------------------------------------------------------------
14194 for my $line_no (sort {$a <=> $b}
14195 (keys %{ $error_and_warning_msgs{"error"} }))
14197 $msg = $g_error_keyword . "[line $line_no] in file";
14198 $msg .= $rc_config_file . " - ";
14199 $msg .= $error_and_warning_msgs{"error"}{$line_no}{"message"};
14200 gp_message
("debug", $subr_name, $msg);
14206 if ($parse_warnings > 0)
14208 $msg = $g_warn_keyword . " found $parse_warnings warnings in";
14209 $msg .= " the configuration file:";
14210 gp_message
("debug", $subr_name, $msg);
14211 for my $line_no (sort {$a <=> $b}
14212 (keys %{ $error_and_warning_msgs{"warning"} }))
14214 $msg = $g_warn_keyword;
14215 $msg .= " [line $line_no] in file $rc_config_file - ";
14216 $msg .= $error_and_warning_msgs{"warning"}{$line_no}{"message"};
14217 gp_message
("debug", $subr_name, $msg);
14223 return ($parse_errors);
14225 } #-- End of subroutine process_rc_file
14227 #------------------------------------------------------------------------------
14228 # Generate the annotated html file for the source listing.
14229 #------------------------------------------------------------------------------
14232 my $subr_name = get_my_name
();
14234 my ($number_of_metrics, $function_info_ref,
14235 $outputdir, $input_filename) = @_;
14237 my @function_info = @
{ $function_info_ref };
14239 #------------------------------------------------------------------------------
14240 # The regex section
14241 #------------------------------------------------------------------------------
14242 my $end_src1_header_regex = '(^\s+)(\d+)\.\s+(.*)';
14243 my $end_src2_header_regex = '(^\s+)(<Function: )(.*)>';
14244 my $function_regex = '^(\s*)<Function:\s(.*)>';
14245 my $function2_regex = '^(\s*)<Function:\s(.*)>';
14246 my $src_regex = '(\s*)(\d+)\.(.*)';
14247 my $txt_ext_regex = '\.txt$';
14248 my $src_filename_id_regex = '^file\.(\d+)\.src\.txt$';
14249 my $integer_only_regex = '\d+';
14250 #------------------------------------------------------------------------------
14251 # Computed dynamically below.
14252 # TBD: Try to move this up.
14253 #------------------------------------------------------------------------------
14254 my $src_times_regex;
14255 my $hot_lines_regex;
14257 my $metric_extra_regex;
14259 my @components = ();
14260 my @fields_in_line = ();
14261 my @file_contents = ();
14262 my @hot_source_lines = ();
14263 my @max_metric_values = ();
14264 my @modified_html = ();
14265 my @transposed_hot_lines = ();
14267 my $colour_coded_line;
14268 my $colour_coded_line_ref;
14271 my $func_name_in_src_file;
14272 my $html_new_line = "<br>";
14275 my $modified_html_ref;
14278 my $start_all_source;
14279 my $start_target_source;
14280 my $end_target_source;
14286 my $decimal_separator = $g_locale_settings{"decimal_separator"};
14287 my $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
14291 my $html_dis_record;
14295 my $rounded_percentage;
14296 my $start_tracking;
14297 my $threshold_line;
14304 my $LANG = $g_locale_settings{"LANG"};
14305 my $the_title = set_title
($function_info_ref, $input_filename,
14307 my $outfile = $input_filename . ".html";
14309 #------------------------------------------------------------------------------
14310 # Remove the .txt from file.<n>.src.txt
14311 #------------------------------------------------------------------------------
14312 my $html_output_file = $input_filename;
14313 $html_output_file =~ s/$txt_ext_regex/.html/;
14315 gp_message
("debug", $subr_name, "input_filename = $input_filename");
14316 gp_message
("debug", $subr_name, "the_title = $the_title");
14318 $file_title = $the_title;
14319 $html_header = ${ create_html_header
(\
$file_title) };
14320 $html_home = ${ generate_home_link
("right") };
14322 push (@modified_html, $html_header);
14323 push (@modified_html, $html_home);
14324 push (@modified_html, "<pre>");
14326 #------------------------------------------------------------------------------
14327 # Open the html file used for the output.
14328 #------------------------------------------------------------------------------
14329 open (NEW_HTML
, ">", $html_output_file)
14330 or die ("$subr_name - unable to open file $html_output_file for writing: '$!'");
14331 gp_message
("debug", $subr_name , "opened file $html_output_file for writing");
14333 $base = get_basename
($input_filename);
14335 gp_message
("debug", $subr_name, "base = $base");
14337 if ($base =~ /$src_filename_id_regex/)
14340 if (defined ($function_info[$file_id]{"routine"}))
14342 $routine = $function_info[$file_id]{"routine"};
14344 gp_message
("debugXL", $subr_name, "target routine = $routine");
14348 my $msg = "cannot retrieve routine name for file_id = $file_id";
14349 gp_message
("assertion", $subr_name, $msg);
14353 #------------------------------------------------------------------------------
14354 # Check if the input file is empty. If so, generate a short text in the html
14355 # file and return. Otherwise open the file and read the contents.
14356 #------------------------------------------------------------------------------
14357 $is_empty = is_file_empty
($input_filename);
14361 #------------------------------------------------------------------------------
14362 # The input file is empty. Write a diagnostic message in the html file and exit.
14363 #------------------------------------------------------------------------------
14364 gp_message
("debug", $subr_name ,"file $input_filename is empty");
14366 my $comment = "No source listing generated by $tool_name - " .
14367 "file $input_filename is empty";
14368 my $error_file = $outputdir . "gp-listings.err";
14370 my $html_empty_file_ref = html_text_empty_file
(\
$comment, \
$error_file);
14371 my @html_empty_file = @
{ $html_empty_file_ref };
14373 print NEW_HTML
"$_\n" for @html_empty_file;
14380 #------------------------------------------------------------------------------
14381 # Open the input file with the source code
14382 #------------------------------------------------------------------------------
14384 open (SRC_LISTING
, "<", $input_filename)
14385 or die ("$subr_name - unable to open file $input_filename for reading: '$!'");
14386 gp_message
("debug", $subr_name, "opened file $input_filename for reading");
14389 #------------------------------------------------------------------------------
14390 # Generate the regex for the metrics. This depends on the number of metrics.
14391 #------------------------------------------------------------------------------
14392 gp_message
("debug", $subr_name, "decimal_separator = $decimal_separator<--");
14394 $metric_regex = '';
14395 $metric_extra_regex = '';
14396 for my $metric_used (1 .. $number_of_metrics)
14398 $metric_regex .= '(\d+' . $decimal_separator . '*\d*)\s+';
14400 $metric_extra_regex = $metric_regex . '(\d+' . $decimal_separator . ')';
14402 $hot_lines_regex = '^(#{2})\s+';
14403 $hot_lines_regex .= '('.$metric_regex.')';
14404 $hot_lines_regex .= '([0-9?]+)\.\s+(.*)';
14406 $src_times_regex = '^(#{2}|\s{2})\s+';
14407 $src_times_regex .= '('.$metric_extra_regex.')';
14408 $src_times_regex .= '(.*)';
14410 gp_message
("debugXL", $subr_name, "metric_regex = $metric_regex");
14411 gp_message
("debugXL", $subr_name, "hot_lines_regex = $hot_lines_regex");
14412 gp_message
("debugXL", $subr_name, "src_times_regex = $src_times_regex");
14413 gp_message
("debugXL", $subr_name, "src_regex = $src_regex");
14415 gp_message
("debugXL", $subr_name, "end_src1_header_regex = $end_src1_header_regex");
14416 gp_message
("debugXL", $subr_name, "end_src2_header_regex = $end_src2_header_regex");
14417 gp_message
("debugXL", $subr_name, "function_regex = $function_regex");
14418 gp_message
("debugXL", $subr_name, "function2_regex = $function2_regex");
14419 gp_message
("debugXL", $subr_name, "src_regex = $src_regex");
14421 #------------------------------------------------------------------------------
14422 # Read the file into memory.
14423 #------------------------------------------------------------------------------
14424 chomp (@file_contents = <SRC_LISTING
>);
14426 #------------------------------------------------------------------------------
14427 # Identify the header lines. Make the minimal assumptions.
14429 # In both cases, the first line after the header has whitespace. This is
14430 # followed by either one of the following:
14435 # These are the characteristics we use below.
14436 #------------------------------------------------------------------------------
14437 for (my $line_number=0; $line_number <= $#file_contents; $line_number++)
14439 $input_line = $file_contents[$line_number];
14441 #------------------------------------------------------------------------------
14442 # We found the first source code line. Bail out.
14443 #------------------------------------------------------------------------------
14444 if (($input_line =~ /$end_src1_header_regex/) or
14445 ($input_line =~ /$end_src2_header_regex/))
14447 gp_message
("debugXL", $subr_name, "header time is over - hit source line");
14448 gp_message
("debugXL", $subr_name, "line_number = $line_number");
14449 gp_message
("debugXL", $subr_name, "input_line = $input_line");
14453 #------------------------------------------------------------------------------
14454 # Store the header lines in the html structure.
14455 #------------------------------------------------------------------------------
14457 $modified_line = "<i>" . $input_line . "</i>";
14458 push (@modified_html, $modified_line);
14461 #------------------------------------------------------------------------------
14462 # We know the source code starts at this index value:
14463 #------------------------------------------------------------------------------
14464 $start_all_source = scalar (@modified_html);
14465 gp_message
("debugXL", $subr_name, "source starts at start_all_source = $start_all_source");
14467 #------------------------------------------------------------------------------
14468 # Scan the file to identify where the target source starts and ends.
14469 #------------------------------------------------------------------------------
14470 gp_message
("debugXL", $subr_name, "search for target function $routine");
14471 $start_tracking = $FALSE;
14472 $found_target = $FALSE;
14473 for (my $line_number=0; $line_number <= $#file_contents; $line_number++)
14475 $input_line = $file_contents[$line_number];
14477 gp_message
("debugXL", $subr_name, "[$line_number] $input_line");
14479 if ($input_line =~ /$function_regex/)
14481 if (defined ($1) and defined ($2))
14483 $func_name_in_src_file = $2;
14484 my $msg = "found a function - name = $func_name_in_src_file";
14485 gp_message
("debugXL", $subr_name, $msg);
14487 if ($start_tracking)
14489 $start_tracking = $FALSE;
14490 $end_target_source = $line_number - 1;
14491 my $msg = "end_target_source = $end_target_source";
14492 gp_message
("debugXL", $subr_name, $msg);
14496 if ($func_name_in_src_file eq $routine)
14498 $found_target = $TRUE;
14499 $start_tracking = $TRUE;
14500 $start_target_source = $line_number;
14502 gp_message
("debugXL", $subr_name, "found target function $routine");
14503 gp_message
("debugXL", $subr_name, "function_name = $2 routine = $routine");
14504 gp_message
("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
14505 gp_message
("debugXL", $subr_name, "start_target_source = $start_target_source");
14510 my $msg = "parsing line $input_line";
14511 gp_message
("assertion", $subr_name, $msg);
14516 #------------------------------------------------------------------------------
14517 # This is not supposed to happen, but it is not a fatal error either. The
14518 # hyperlinks related to this function will not work, so a warning is issued.
14519 # A message is issued both in debug mode, and as a warning.
14520 #------------------------------------------------------------------------------
14521 if (not $found_target)
14524 gp_message
("debug", $subr_name, "target function $routine not found");
14526 $msg = "function $routine not found in $base - " .
14527 "links to source code involving this function will not work";
14528 gp_message
("warning", $subr_name, $msg);
14530 return ($found_target);
14533 #------------------------------------------------------------------------------
14534 # Catch the line number of the last function.
14535 #------------------------------------------------------------------------------
14536 if ($start_tracking)
14538 $end_target_source = $#file_contents;
14540 gp_message
("debugXL", $subr_name, "routine = $routine start_tracking = $start_tracking");
14541 gp_message
("debugXL", $subr_name, "start_target_source = $start_target_source");
14542 gp_message
("debugXL", $subr_name, "end_target_source = $end_target_source");
14544 #------------------------------------------------------------------------------
14545 # We now have the index range for the function of interest and will parse it.
14546 # Since we already handled the first line with the function marker, we start
14547 # with the line following.
14548 #------------------------------------------------------------------------------
14550 #------------------------------------------------------------------------------
14551 # Find the hot source lines and store them.
14552 #------------------------------------------------------------------------------
14553 gp_message
("debugXL", $subr_name, "determine the maximum metric values");
14554 for (my $line_number=$start_target_source+1; $line_number <= $end_target_source; $line_number++)
14556 $input_line = $file_contents[$line_number];
14557 gp_message
("debugXL", $subr_name, " $line_number : check input_line = $input_line");
14559 if ( $input_line =~ /$hot_lines_regex/ )
14561 gp_message
("debugXL", $subr_name, " $line_number : found a hot line");
14562 #------------------------------------------------------------------------------
14563 # We found a hot line and the metric fields are stored in $2. We turn this
14564 # string into an array and add it as a row to hot_source_lines.
14565 #------------------------------------------------------------------------------
14567 $metric_values = $2;
14569 gp_message
("debugXL", $subr_name, "hot_line = $hot_line");
14570 gp_message
("debugXL", $subr_name, "metric_values = $metric_values");
14572 my @metrics = split (" ", $metric_values);
14573 push (@hot_source_lines, [@metrics]);
14575 gp_message
("debugXL", $subr_name, " $line_number : completed check for hot line");
14578 #------------------------------------------------------------------------------
14579 # Transpose the array with the hot lines. This means each row has all the
14580 # values for a metrict and it makes it easier to determine the maximum values.
14581 #------------------------------------------------------------------------------
14582 for my $row (keys @hot_source_lines)
14584 my $msg = "row[" . $row . "] =";
14585 for my $col (keys @
{$hot_source_lines[$row]})
14587 $msg .= " $hot_source_lines[$row][$col]";
14588 $transposed_hot_lines[$col][$row] = $hot_source_lines[$row][$col];
14592 #------------------------------------------------------------------------------
14593 # Print the maximum metric values found. Each row contains the data for a
14594 # different metric.
14595 #------------------------------------------------------------------------------
14596 for my $row (keys @transposed_hot_lines)
14598 my $msg = "row[" . $row . "] =";
14599 for my $col (keys @
{$transposed_hot_lines[$row]})
14601 $msg .= " $transposed_hot_lines[$row][$col]";
14603 gp_message
("debugXL", $subr_name, "hot lines = $msg");
14606 #------------------------------------------------------------------------------
14607 # Determine the maximum value for each metric.
14608 #------------------------------------------------------------------------------
14609 for my $row (keys @transposed_hot_lines)
14612 for my $col (keys @
{$transposed_hot_lines[$row]})
14614 $max_val = max
($transposed_hot_lines[$row][$col], $max_val);
14616 #------------------------------------------------------------------------------
14617 # Convert to a floating point number.
14618 #------------------------------------------------------------------------------
14619 if ($max_val =~ /$integer_only_regex/)
14621 $max_val = sprintf ("%f", $max_val);
14623 push (@max_metric_values, $max_val);
14626 for my $metric (keys @max_metric_values)
14628 my $msg = "$input_filename max_metric_values[$metric] = " .
14629 $max_metric_values[$metric];
14630 gp_message
("debugXL", $subr_name, $msg);
14633 #------------------------------------------------------------------------------
14634 # Process those functions that are not the current target.
14635 #------------------------------------------------------------------------------
14636 $modified_html_ref = process_non_target_source
($start_all_source,
14637 $start_target_source-1,
14640 $number_of_metrics,
14643 @modified_html = @
{ $modified_html_ref };
14645 #------------------------------------------------------------------------------
14646 # This is the core part to process the information for the target function.
14647 #------------------------------------------------------------------------------
14648 gp_message
("debugXL", $subr_name, "parse and process the target source");
14649 $modified_html_ref = process_target_source
($start_target_source,
14650 $end_target_source,
14652 \
@max_metric_values,
14655 $number_of_metrics,
14658 @modified_html = @
{ $modified_html_ref };
14660 if ($end_target_source < $#file_contents)
14662 $modified_html_ref = process_non_target_source
($end_target_source+1,
14666 $number_of_metrics,
14669 @modified_html = @
{ $modified_html_ref };
14672 gp_message
("debug", $subr_name, "completed reading source");
14674 #------------------------------------------------------------------------------
14675 # Add an extra line with diagnostics.
14677 # TBD: The same is done in generate_dis_html but should be done only once.
14678 #------------------------------------------------------------------------------
14681 my $rounded_percentage = sprintf ("%.1f", $hp_value);
14682 $threshold_line = "<i>The setting for the highlight percentage";
14683 $threshold_line .= " (--highlight-percentage) option:";
14684 $threshold_line .= " " . $rounded_percentage . " (%)</i>";
14688 $threshold_line = "<i>The highlight percentage feature has not been";
14689 $threshold_line .= " enabled</i>";
14692 $html_home = ${ generate_home_link
("left") };
14693 $html_end = ${ terminate_html_document
() };
14695 push (@modified_html, "</pre>");
14696 push (@modified_html, "<br>");
14697 push (@modified_html, $threshold_line);
14698 push (@modified_html, $html_home);
14699 push (@modified_html, "<br>");
14700 push (@modified_html, $g_html_credits_line);
14701 push (@modified_html, $html_end);
14703 for my $i (0 .. $#modified_html)
14705 gp_message
("debugXL", $subr_name, "[$i] -> $modified_html[$i]");
14708 #------------------------------------------------------------------------------
14709 # Write the generated HTML text to file.
14710 #------------------------------------------------------------------------------
14711 for my $i (0 .. $#modified_html)
14713 print NEW_HTML
"$modified_html[$i]" . "\n";
14716 close (SRC_LISTING
);
14718 return ($found_target);
14720 } #-- End of subroutine process_source
14722 #------------------------------------------------------------------------------
14723 # Process the source lines for the target function.
14724 #------------------------------------------------------------------------------
14725 sub process_target_source
14727 my $subr_name = get_my_name
();
14729 my ($start_scan, $end_scan, $target_function, $max_metric_values_ref,
14730 $src_times_regex, $function2_regex, $number_of_metrics,
14731 $file_contents_ref, $modified_html_ref) = @_;
14733 my @file_contents = @
{ $file_contents_ref };
14734 my @modified_html = @
{ $modified_html_ref };
14735 my @max_metric_values = @
{ $max_metric_values_ref };
14737 my @components = ();
14739 my $colour_coded_line;
14740 my $colour_coded_line_ref;
14749 gp_message
("debug", $subr_name, "parse and process the core loop");
14751 for (my $line_number=$start_scan; $line_number <= $end_scan; $line_number++)
14753 $input_line = $file_contents[$line_number];
14755 #------------------------------------------------------------------------------
14756 # We need to replace the "<" symbol in the code by "<".
14757 #------------------------------------------------------------------------------
14758 $input_line =~ s/$g_less_than_regex/$g_html_less_than_regex/g;
14760 $line_id = extract_source_line_number
($src_times_regex,
14762 $number_of_metrics,
14765 gp_message
("debug", $subr_name, "line_number = $line_number : input_line = $input_line line_id = $line_id");
14767 if ($input_line =~ /$function2_regex/)
14768 #------------------------------------------------------------------------------
14769 # Found the function marker.
14770 #------------------------------------------------------------------------------
14772 if (defined ($1) and defined ($2))
14774 my $func_name_in_file = $2;
14776 my $boldface = $TRUE;
14777 gp_message
("debug", $subr_name, "function_name = $2");
14778 my $function_line = "<Function: " . $func_name_in_file . ">";
14779 my $color_function_name = color_string
(
14782 $g_html_color_scheme{"target_function_name"});
14784 if (exists ($g_function_tag_id{$target_function}))
14786 $ftag = $g_function_tag_id{$target_function};
14787 gp_message
("debug", $subr_name, "target_function = $target_function ftag = $ftag");
14791 my $msg = "no ftag found for $target_function";
14792 gp_message
("assertion", $subr_name, $msg);
14794 $modified_line = "<a id=\"" . $ftag . "\"></a>";
14795 $modified_line .= $spaces . "<i>" . $color_function_name . "</i>";
14798 elsif ($input_line =~ /$src_times_regex/)
14799 #------------------------------------------------------------------------------
14800 # This is a line with metric values.
14801 #------------------------------------------------------------------------------
14803 gp_message
("debug", $subr_name, "input line has metrics");
14806 $metric_values = $2;
14808 $src_code_line = $4;
14810 gp_message
("debug", $subr_name, "hot_line = $hot_line");
14811 gp_message
("debug", $subr_name, "metric_values = $metric_values");
14812 gp_message
("debug", $subr_name, "src_line_no = $src_line_no");
14813 gp_message
("debug", $subr_name, "src_code_line = $src_code_line");
14815 if ($hot_line eq "##")
14816 #------------------------------------------------------------------------------
14817 # Highlight the most expensive line.
14818 #------------------------------------------------------------------------------
14820 @components = split (" ", $input_line, 1+$number_of_metrics+2);
14821 $modified_line = set_background_color_string
(
14823 $g_html_color_scheme{"background_color_hot"});
14827 #------------------------------------------------------------------------------
14828 # Highlight those lines close enough to the most expensive line.
14829 #------------------------------------------------------------------------------
14830 @components = split (" ", $input_line, $number_of_metrics + 2);
14831 for my $i (0 .. $number_of_metrics-1)
14833 gp_message
("debugXL", $subr_name, "$line_number : time check components[$i] = $components[$i]");
14836 $colour_coded_line_ref = check_metric_values
($metric_values, \
@max_metric_values);
14838 $colour_coded_line = $ {$colour_coded_line_ref};
14839 if ($colour_coded_line)
14841 gp_message
("debugXL", $subr_name, "$line_number : change background colour modified_line = $modified_line");
14842 $modified_line = set_background_color_string
($input_line, $g_html_color_scheme{"background_color_lukewarm"});
14846 $modified_line = "<a id=\"line_" . $line_id . "\"></a>";
14847 $modified_line .= "$input_line";
14852 #------------------------------------------------------------------------------
14853 # This is a regular line that is not modified.
14854 #------------------------------------------------------------------------------
14856 #------------------------------------------------------------------------------
14858 #------------------------------------------------------------------------------
14859 gp_message
("debug", $subr_name, "$line_number : input line is a regular line");
14860 $modified_line = "<a id=\"line_" . $line_id . "\"></a>";
14861 $modified_line .= "$input_line";
14863 gp_message
("debug", $subr_name, "$line_number : mod = $modified_line");
14864 push (@modified_html, $modified_line);
14867 return (\
@modified_html);
14869 } #-- End of subroutine process_target_source
14871 #------------------------------------------------------------------------------
14872 # Process the options. Set associated variables and check the options for
14873 # correctness. For example, detect if conflicting options have been set.
14874 #------------------------------------------------------------------------------
14875 sub process_user_options
14877 my $subr_name = get_my_name
();
14879 my ($exp_dir_list_ref) = @_;
14881 my @exp_dir_list = @
{ $exp_dir_list_ref };
14883 my %ignored_metrics = ();
14886 my @candidate_ignored_metrics = ();
14895 my $mkdir_output_msg;
14896 my $time_percentage_multiplier;
14897 my $process_all_functions;
14899 #------------------------------------------------------------------------------
14900 # The -o and -O options are mutually exclusive.
14901 #------------------------------------------------------------------------------
14902 my $define_new_output_dir = $g_user_settings{"output"}{"defined"};
14903 my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"};
14904 my $dir_o_option = $g_user_settings{"output"}{"current_value"};
14905 my $dir_O_option = $g_user_settings{"overwrite"}{"current_value"};
14907 if ($define_new_output_dir and $overwrite_output_dir)
14909 $msg = "the -o/--output and -O/--overwrite options are both set, " .
14910 "but are mutually exclusive";
14911 gp_message
("error", $subr_name, $msg);
14913 $msg = "(setting for -o = $dir_o_option, " .
14914 "setting for -O = $dir_O_option)";
14915 gp_message
("error", $subr_name, $msg);
14917 $g_total_error_count++;
14920 #------------------------------------------------------------------------------
14921 # The warnings option is deprecated. Print a warning to this extent and point
14922 # to the --nowarnings option.
14923 #------------------------------------------------------------------------------
14924 #------------------------------------------------------------------------------
14925 # Handle the situation that both or one of the highlight-percentage and hp
14927 #------------------------------------------------------------------------------
14928 if ($g_user_settings{"warnings"}{"defined"})
14930 $msg = "<br>" . "the --warnings option has been deprecated and";
14931 $msg .= " will be ignored";
14932 gp_message
("warning", $subr_name, $msg);
14934 if ($g_user_settings{"nowarnings"}{"defined"})
14936 $msg = "since the --nowarnings option is also used, warnings";
14937 $msg .= " are disabled";
14938 gp_message
("warning", $subr_name, $msg);
14942 $msg = "by default, warnings are enabled and can be disabled with";
14943 gp_message
("warning", $subr_name, $msg);
14944 $msg = " the --nowarnings option";
14945 gp_message
("warning", $subr_name, $msg);
14947 $g_total_warning_count++;
14950 #------------------------------------------------------------------------------
14951 # In case both the --highlight-percentage and -hp option are set, issue a
14952 # warning and continue with the --highlight-percentage value.
14953 #------------------------------------------------------------------------------
14954 if ($g_user_settings{"hp"}{"defined"})
14956 $msg = "<br>" . "the -hp option has been deprecated and";
14957 $msg .= " will be ignored";
14958 gp_message
("warning", $subr_name, $msg);
14960 if ($g_user_settings{"highlight_percentage"}{"defined"})
14962 $msg = "since the --highlight-percentage option is also used,";
14963 $msg .= " the value of ";
14964 $msg .= $g_user_settings{"highlight_percentage"}{"current_value"};
14965 $msg .= " will be applied";
14966 gp_message
("warning", $subr_name, $msg);
14970 #------------------------------------------------------------------------------
14971 # If only the -hp option is set, we use it, because we do not want to break
14972 # compatibility (yet) and force the user to change the option.
14973 #------------------------------------------------------------------------------
14975 ## FUTURE $msg = "instead, the default setting of "
14976 ## FUTURE $msg .= $g_user_settings{"highlight_percentage"}{"current_value"};
14977 ## FUTURE $msg .= " for the --highlight-percentage will be used";
14978 ## FUTURE gp_message ("warning", $subr_name, $msg);
14980 ## FUTURE $msg = "please use this option to set the highlighting value";
14981 ## FUTURE gp_message ("warning", $subr_name, $msg);
14983 $g_user_settings{"highlight_percentage"}{"current_value"} =
14984 $g_user_settings{"hp"}{"current_value"};
14986 $g_user_settings{"highlight_percentage"}{"defined"} = $TRUE;
14988 $msg = "for now, the value of " .
14989 $g_user_settings{"hp"}{"current_value"} .
14990 " for the -hp option is used, but please change the" .
14991 " option to --highlight-percentage";
14992 gp_message
("warning", $subr_name, $msg);
14995 $g_total_warning_count++;
14998 #------------------------------------------------------------------------------
14999 # Regardless of the use of the -hp option, we continue with the value for
15000 # highlight-percentage. Some more checks are carried out now.
15001 #------------------------------------------------------------------------------
15003 #------------------------------------------------------------------------------
15004 # This value should be in the interval [0,100].
15005 # the number to be positive, but the limits have not been checked yet.
15006 #------------------------------------------------------------------------------
15007 $hp_value = $g_user_settings{"highlight_percentage"}{"current_value"};
15009 if (($hp_value < 0) or ($hp_value > 100))
15011 $msg = "the value for the highlight percentage is set to $hp_value,";
15012 $msg .= " but must be in the range [0, 100]";
15013 gp_message
("error", $subr_name, $msg);
15015 $g_total_error_count++;
15017 elsif ($hp_value == 0.0)
15018 #------------------------------------------------------------------------------
15019 # A value of zero is interpreted to mean that highlighting should be disabled.
15020 # To make the checks for this later on easier, set it to an integer value of 0.
15021 #------------------------------------------------------------------------------
15023 $g_user_settings{"highlight_percentage"}{"current_value"} = 0;
15025 $msg = "reset the highlight percentage value from 0.0 to";
15026 $msg .= " " . $g_user_settings{"highlight_percentage"}{"current_value"};
15027 gp_message
("debug", $subr_name, $msg);
15030 #------------------------------------------------------------------------------
15031 # The value for TP should be in the interval (0,100]. We already enforced
15032 # the number to be positive, but the limits have not been checked yet.
15033 #------------------------------------------------------------------------------
15034 my $tp_value = $g_user_settings{"threshold_percentage"}{"current_value"};
15036 if (($tp_value < 0) or ($tp_value > 100))
15038 $msg = "the value for the total percentage is set to $tp_value,";
15039 $msg .= " but must be in the range (0, 100]";
15040 gp_message
("error", $subr_name, $msg);
15042 $g_total_error_count++;
15046 $time_percentage_multiplier = $tp_value/100.0;
15048 # Ruud if (($TIME_PERCENTAGE_MULTIPLIER*100.) >= 100.)
15050 if ($tp_value == 100)
15052 $process_all_functions = $TRUE; # ensure that all routines are handled
15056 $process_all_functions = $FALSE;
15059 $msg = "value of time_percentage_multiplier = " .
15060 $time_percentage_multiplier;
15061 gp_message
("debugM", $subr_name, $msg);
15062 $msg = "value of process_all_functions = " .
15063 ($process_all_functions ?
"TRUE" : "FALSE");
15064 gp_message
("debugM", $subr_name, $msg);
15067 #------------------------------------------------------------------------------
15068 # If imetrics has been set, split the list into the individual metrics that
15069 # need to be excluded. The associated hash called $ignore_metrics has the
15070 # to be excluded metrics as an index. The value of $TRUE assigned does not
15072 #------------------------------------------------------------------------------
15073 if ($g_user_settings{"ignore_metrics"}{"defined"})
15075 @candidate_ignored_metrics =
15076 split (":", $g_user_settings{"ignore_metrics"}{"current_value"});
15078 for my $metric (@candidate_ignored_metrics)
15080 # TBD: bug? $ignored_metrics{$metric} = $FALSE;
15081 $ignored_metrics{$metric} = $TRUE;
15083 for my $metric (keys %ignored_metrics)
15085 my $msg = "ignored_metrics{$metric} = $ignored_metrics{$metric}";
15086 gp_message
("debugM", $subr_name, $msg);
15089 #------------------------------------------------------------------------------
15090 # Check if the experiment directories exist and if they do, add the absolute
15091 # path. This is easier in the remainder.
15092 #------------------------------------------------------------------------------
15093 for my $i (0 .. $#exp_dir_list)
15095 if (-d
$exp_dir_list[$i])
15097 $abs_path_dir = Cwd
::abs_path
($exp_dir_list[$i]);
15098 $exp_dir_list[$i] = $abs_path_dir;
15100 $msg = "directory $exp_dir_list[$i] exists";
15101 gp_message
("debugM", $subr_name, $msg);
15105 return (\
%ignored_metrics, $outputdir, $time_percentage_multiplier,
15106 $process_all_functions, \
@exp_dir_list);
15108 } #-- End of subroutine process_user_options
15110 #------------------------------------------------------------------------------
15111 # This is a hopefully temporary routine to disable/ignore selected user
15112 # settings. As the functionality expands, this list will get shorter.
15113 #------------------------------------------------------------------------------
15114 sub reset_selected_settings
15116 my $subr_name = get_my_name
();
15118 $g_locale_settings{"decimal_separator"} = "\\.";
15119 $g_locale_settings{"convert_to_dot"} = $FALSE;
15120 $g_user_settings{func_limit
}{current_value
} = 1000000;
15122 gp_message
("debug", $subr_name, "reset selected settings");
15126 } #-- End of subroutine reset_selected_settings
15128 #------------------------------------------------------------------------------
15129 # There may be various different visibility characters in a metric definition.
15130 # For example: e+%CPI.
15132 # Internally we use a normalized definition that only uses the dot (e.g.
15133 # e.CPI) as an index into the description structure.
15135 # Here we reduce the incoming metric definition to the normalized form, look
15136 # up the text, and return a pointer to it.
15137 #------------------------------------------------------------------------------
15138 sub retrieve_metric_description
15140 my $subr_name = get_my_name
();
15142 my ($metric_name_ref, $metric_description_ref) = @_;
15144 my $metric_name = ${ $metric_name_ref };
15145 my %metric_description = %{ $metric_description_ref };
15148 my $normalized_metric;
15150 $metric_name =~ /([ei])([\.\+%]+)(.*)/;
15152 if (defined ($1) and defined ($3))
15154 $normalized_metric = $1 . "." . $3;
15158 my $msg = "metric $metric_name has an unknown format";
15159 gp_message
("assertion", $subr_name, $msg);
15162 if (defined ($metric_description{$normalized_metric}))
15164 $description = $metric_description{$normalized_metric};
15168 my $msg = "description for normalized metric $normalized_metric not found";
15169 gp_message
("assertion", $subr_name, $msg);
15172 return (\
$description);
15174 } #-- End of subroutine retrieve_metric_description
15176 #------------------------------------------------------------------------------
15178 #------------------------------------------------------------------------------
15182 if ($a =~ /^([^\d]*)(\d+)/)
15185 if ($b=~ /^([^\d]*)(\d+)/)
15188 $f1 == $f2 ?
0 : ($f1 > $f2 ?
-1 : +1);
15193 return ($b <=> $a);
15195 } #-- End of subroutine rnumerically
15197 #------------------------------------------------------------------------------
15198 # TBD: Remove - not used any longer.
15199 # Set the architecture and associated regular expressions.
15200 #------------------------------------------------------------------------------
15201 sub set_arch_and_regexes
15203 my $subr_name = get_my_name
();
15205 my ($arch_uname) = @_;
15207 my $architecture_supported;
15209 gp_message
("debug", $subr_name, "arch_uname = $arch_uname");
15211 if ($arch_uname eq "x86_64")
15213 #x86/x64 hardware uses jump
15214 $architecture_supported = $TRUE;
15216 # $regex=':\s+(j).*0x[0-9a-f]+';
15217 # $subexp='(\[\s*)(0x[0-9a-f]+)';
15218 # $linksubexp='(\[\s*)(0x[0-9a-f]+)';
15219 gp_message
("debug", $subr_name, "detected $arch_uname hardware");
15221 $architecture_supported = $TRUE;
15222 $g_arch_specific_settings{"arch_supported"} = $TRUE;
15223 $g_arch_specific_settings{"arch"} = 'x64';
15224 $g_arch_specific_settings{"regex"} = ':\s+(j).*0x[0-9a-f]+';
15225 $g_arch_specific_settings{"subexp"} = '(\[\s*)(0x[0-9a-f]+)';
15226 $g_arch_specific_settings{"linksubexp"} = '(\[\s*)(0x[0-9a-f]+)';
15228 #------------------------------------------------------------------------------
15229 # TBD: Remove the elsif block
15230 #------------------------------------------------------------------------------
15231 elsif ($arch_uname=~m/sparc/s)
15233 #sparc hardware uses branch
15234 $architecture_supported = $FALSE;
15236 # $regex=':\s+(c|b|fb).*0x[0-9a-f]+\s*$';
15237 # $subexp='(\s*)(0x[0-9a-f]+)\s*$';
15238 # $linksubexp='(\s*)(0x[0-9a-f]+\s*$)';
15239 # gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch - this is no longer supported");
15240 $architecture_supported = $FALSE;
15241 $g_arch_specific_settings{arch_supported
} = $FALSE;
15242 $g_arch_specific_settings{arch
} = 'sparc';
15243 $g_arch_specific_settings{regex
} = ':\s+(c|b|fb).*0x[0-9a-f]+\s*$';
15244 $g_arch_specific_settings{subexp
} = '(\s*)(0x[0-9a-f]+)\s*$';
15245 $g_arch_specific_settings{linksubexp
} = '(\s*)(0x[0-9a-f]+\s*$)';
15249 $architecture_supported = $FALSE;
15250 gp_message
("debug", $subr_name, "detected $arch_uname hardware - this not supported; limited functionality");
15253 return ($architecture_supported);
15255 } #-- End of subroutine set_arch_and_regexes
15257 #------------------------------------------------------------------------------
15258 # Set the background color of the input string.
15260 # For supported colors, see:
15261 # https://www.w3schools.com/colors/colors_names.asp
15262 #------------------------------------------------------------------------------
15263 sub set_background_color_string
15265 my $subr_name = get_my_name
();
15267 my ($input_string, $color) = @_;
15269 my $background_color_string;
15272 $msg = "color = $color input_string = $input_string";
15273 gp_message
("debugXL", $subr_name, $msg);
15275 $background_color_string = "<span style='background-color: " . $color .
15276 "'>" . $input_string . "</span>";
15278 $msg = "color = $color background_color_string = " .
15279 $background_color_string;
15280 gp_message
("debugXL", $subr_name, $msg);
15282 return ($background_color_string);
15284 } #-- End of subroutine set_background_color_string
15286 #------------------------------------------------------------------------------
15287 # Set the g_debug_size structure for a given value for "size". Also set the
15288 # value in $g_user_settings{"debug"}{"current_value"}
15289 #------------------------------------------------------------------------------
15292 my $subr_name = get_my_name
();
15294 my $debug_value = lc ($g_user_settings{"debug"}{"current_value"});
15296 #------------------------------------------------------------------------------
15297 # Set the corresponding sizes in the table. A value of "on" is equivalent to
15299 #------------------------------------------------------------------------------
15300 if (($debug_value eq "on") or ($debug_value eq "s"))
15302 $g_debug_size{"on"} = $TRUE;
15303 $g_debug_size{"s"} = $TRUE;
15305 elsif ($debug_value eq "m")
15307 $g_debug_size{"on"} = $TRUE;
15308 $g_debug_size{"s"} = $TRUE;
15309 $g_debug_size{"m"} = $TRUE;
15311 elsif ($debug_value eq "l")
15313 $g_debug_size{"on"} = $TRUE;
15314 $g_debug_size{"s"} = $TRUE;
15315 $g_debug_size{"m"} = $TRUE;
15316 $g_debug_size{"l"} = $TRUE;
15318 elsif ($debug_value eq "xl")
15320 $g_debug_size{"on"} = $TRUE;
15321 $g_debug_size{"s"} = $TRUE;
15322 $g_debug_size{"m"} = $TRUE;
15323 $g_debug_size{"l"} = $TRUE;
15324 $g_debug_size{"xl"} = $TRUE;
15327 #------------------------------------------------------------------------------
15328 # Any other value is considered to disable debugging.
15329 #------------------------------------------------------------------------------
15331 ## $g_user_settings{"debug"}{"current_value"} = "off";
15333 $g_debug_size{"on"} = $FALSE;
15334 $g_debug_size{"s"} = $FALSE;
15335 $g_debug_size{"m"} = $FALSE;
15336 $g_debug_size{"l"} = $FALSE;
15337 $g_debug_size{"xl"} = $FALSE;
15340 #------------------------------------------------------------------------------
15341 # Activate in case of an emergency :-)
15342 #------------------------------------------------------------------------------
15343 my $show_sizes = $FALSE;
15347 if ($g_debug_size{$debug_value})
15349 for my $i (keys %g_debug_size)
15351 print "$subr_name g_debug_size{$i} = $g_debug_size{$i}\n";
15358 } #-- End of subroutine set_debug_size
15360 #------------------------------------------------------------------------------
15361 # This subroutine defines the default metrics.
15362 #------------------------------------------------------------------------------
15363 sub set_default_metrics
15365 my $subr_name = get_my_name
();
15367 my ($outfile1, $ignored_metrics_ref) = @_;
15369 my %ignored_metrics = %{ $ignored_metrics_ref };
15371 my %metric_description = ();
15372 my %metric_found = ();
15374 my $detail_metrics;
15375 my $detail_metrics_system;
15377 my $call_metrics = "";
15378 my $summary_metrics = "";
15380 open (METRICS
, "<", $outfile1)
15381 or die ("Unable to open metrics file $outfile1 for reading - '$!'");
15382 gp_message
("debug", $subr_name, "opened $outfile1 for reading");
15386 my $metric_line = $_;
15387 chomp ($metric_line);
15389 gp_message
("debug", $subr_name,"the value of metric_line = $metric_line");
15391 #------------------------------------------------------------------------------
15392 # Decode the metric part of the input line. If a valid line, return the
15393 # metric components. Otherwise return "skipped" in the metric_spec field.
15394 #------------------------------------------------------------------------------
15395 my ($metric_spec, $metric_flavor, $metric_visibility, $metric_name, $metric_description) = extract_metric_specifics
($metric_line);
15397 gp_message
("debug", $subr_name, "metric_spec = $metric_spec");
15398 gp_message
("debug", $subr_name, "metric_flavor = $metric_flavor");
15400 if ($metric_spec eq "skipped")
15401 #------------------------------------------------------------------------------
15402 # Not a valid input line.
15403 #------------------------------------------------------------------------------
15405 gp_message
("debug", $subr_name, "skipped line: $metric_line");
15409 #------------------------------------------------------------------------------
15410 # A valid metric field has been found.
15411 #------------------------------------------------------------------------------
15412 gp_message
("debug", $subr_name, "metric_name = $metric_name");
15413 gp_message
("debug", $subr_name, "metric_description = $metric_description");
15415 # if (exists ($IMETRICS{$m})){
15416 if ($g_user_settings{"ignore_metrics"}{"defined"} and exists ($ignored_metrics{$metric_name}))
15418 gp_message
("debug", $subr_name, "user requested to ignore metric $metric_name");
15422 #------------------------------------------------------------------------------
15423 # Only the exclusive metric is selected.
15424 #------------------------------------------------------------------------------
15425 if ($metric_flavor eq "e")
15427 $metric_found{$metric_spec} = $TRUE;
15428 $metric_description{$metric_spec} = $metric_description;
15430 # TBD: remove the -AO:
15431 gp_message
("debug", $subr_name,"-AO metric_description{$metric_spec} = $metric_description{$metric_spec}");
15433 $summary_metrics .= $metric_spec.":";
15434 $call_metrics .= "a.".$metric_name.":";
15440 chop ($call_metrics);
15441 chop ($summary_metrics);
15443 $detail_metrics = $summary_metrics;
15444 $detail_metrics_system = $summary_metrics;
15446 return (\
%metric_description, \
%metric_found,
15447 $summary_metrics, $detail_metrics, $detail_metrics_system, $call_metrics);
15449 } #-- End of subroutine set_default_metrics
15451 #------------------------------------------------------------------------------
15452 # Set various system specific variables. These depend upon both the processor
15453 # architecture and OS. The values are stored in global structure
15454 # g_arch_specific_settings.
15455 #------------------------------------------------------------------------------
15456 sub set_system_specific_variables
15458 my $subr_name = get_my_name
();
15460 my ($arch_uname, $arch_uname_s) = @_;
15465 my $architecture_supported;
15471 if ($arch_uname eq "x86_64")
15473 #------------------------------------------------------------------------------
15474 # x86/x64 hardware uses jump
15475 #------------------------------------------------------------------------------
15476 $architecture_supported = $TRUE;
15478 $regex =':\s+(j).*0x[0-9a-f]+';
15479 $subexp ='(\[\s*)(0x[0-9a-f]+)';
15480 $linksubexp ='(\[\s*)(0x[0-9a-f]+)';
15482 # gp_message ("debug", $subr_name, "detected $arch_uname hardware arch = $arch");
15484 $g_arch_specific_settings{"arch_supported"} = $TRUE;
15485 $g_arch_specific_settings{"arch"} = 'x64';
15486 #------------------------------------------------------------------------------
15487 # Define the regular expressions to parse branch instructions.
15488 #------------------------------------------------------------------------------
15490 #------------------------------------------------------------------------------
15491 # TBD: Need much more than these
15492 #------------------------------------------------------------------------------
15493 $g_arch_specific_settings{"regex"} = '\.*([0-9a-fA-F]*):\s+(j).*\s*0x([0-9a-fA-F]+)';
15494 $g_arch_specific_settings{"subexp"} = '(0x[0-9a-f]+)';
15495 $g_arch_specific_settings{"linksubexp"} = '(\s*)(0x[0-9a-f]+)';
15499 $architecture_supported = $FALSE;
15500 $g_arch_specific_settings{"arch_supported"} = $FALSE;
15503 #------------------------------------------------------------------------------
15504 # TBD Ruud: need to handle this better
15505 #------------------------------------------------------------------------------
15506 if ($arch_uname_s eq "Linux")
15508 $elf_arch = $arch_uname_s;
15509 $read_elf_cmd = $g_mapped_cmds{"readelf"};
15511 if ($read_elf_cmd eq "road to nowhere")
15513 $elf_support = $FALSE;
15517 $elf_support = $TRUE;
15519 gp_message
("debugXL", $subr_name, "elf_support = $elf_support read_elf_cmd = $read_elf_cmd elf_arch = $elf_arch");
15523 gp_message
("abort", $subr_name, "the $arch_uname_s operating system is not supported");
15526 return ($architecture_supported, $elf_arch, $elf_support);
15528 } #-- End of subroutine set_system_specific_variables
15530 #------------------------------------------------------------------------------
15532 #------------------------------------------------------------------------------
15535 my $subr_name = get_my_name
();
15537 my ($function_info_ref, $func, $from_where) = @_ ;
15540 my @function_info = @
{$function_info_ref};
15541 my $filename = $func ;
15555 $base = get_basename
($filename);
15557 gp_message
("debug", $subr_name, "from_where = $from_where");
15558 gp_message
("debug", $subr_name, "base = $base filename = $filename");
15560 if ($from_where eq "process source")
15562 if ($base =~ /^file\.(\d+)\.src\.txt$/)
15570 $msg = "unexpected error encountered parsing $filename";
15571 gp_message
("assertion", $subr_name, $msg);
15574 $the_title = "Source";
15576 elsif ($from_where eq "disassembly")
15578 if ($base =~ /^file\.(\d+)\.dis$/)
15586 $msg = "unexpected error encountered parsing $filename";
15587 gp_message
("assertion", $subr_name, $msg);
15590 $the_title = "Disassembly";
15594 $msg = "called from unknown routine - $from_where";
15595 gp_message
("assertion", $subr_name, $msg);
15598 if (defined ($function_info[$RI]{"routine"}))
15600 $routine = $function_info[$RI]{"routine"};
15603 if ($from_where eq "process source")
15605 $file_is_empty = is_file_empty
($filename);
15607 if ($file_is_empty)
15613 open ($SRC, "<", $filename)
15614 or die ("$subr_name - unable to open source file $filename for reading:'$!'");
15615 gp_message
("debug", $subr_name, "opened file $filename for reading");
15617 $first_line = <$SRC>;
15618 chomp ($first_line);
15622 gp_message
("debug", $subr_name, "first_line = $first_line");
15624 if ($first_line =~ /^Source\s+file:\s+([^\s]+)/)
15634 elsif ($from_where eq "disassembly")
15636 $msg = "unable to open disassembly file $filename for reading:";
15637 open ($DIS, "<", $filename)
15638 or die ($subr_name . " - " . $msg . " " . $!);
15639 gp_message
("debug", $subr_name, "opened file $filename for reading");
15641 $file_is_empty = is_file_empty
($filename);
15643 if ($file_is_empty)
15644 #------------------------------------------------------------------------------
15645 # Currently, the disassembly file for <static> functions appears to be empty
15646 # on aarch64. This might be a bug, but it is in any case better to handle
15648 #------------------------------------------------------------------------------
15651 $msg = "file $filename is empty";
15652 gp_message
("debugM", $subr_name, $msg);
15656 $first_line = <$DIS>;
15661 if ($first_line =~ /^Source\s+file:\s+([^\s]+)/)
15671 if (length ($routine))
15673 $the_title .= " $routine";
15676 if (length ($src_file))
15678 if ($src_file ne "(unknown)")
15680 $the_title .= " ($src_file)";
15684 $the_title .= " $src_file";
15688 return ($the_title);
15690 } #-- End of subroutine set_title
15692 #------------------------------------------------------------------------------
15693 # Handles where the output should go. If needed, a directory to store the
15694 # results in is created.
15695 #------------------------------------------------------------------------------
15696 sub set_up_output_directory
15698 my $subr_name = get_my_name
();
15702 my $mkdir_output_msg;
15703 my $outputdir = "does_not_exist_yet";
15708 my $define_new_output_dir = $g_user_settings{"output"}{"defined"};
15709 my $overwrite_output_dir = $g_user_settings{"overwrite"}{"defined"};
15711 if ((not $define_new_output_dir) and (not $overwrite_output_dir))
15712 #------------------------------------------------------------------------------
15713 # If neither -o or -O are set, find the next number to be used in the name for
15714 # the default output directory.
15715 #------------------------------------------------------------------------------
15718 while (-d
"display.".$dir_id.".html")
15720 $outputdir = "display.".$dir_id.".html";
15722 elsif ($define_new_output_dir)
15723 #------------------------------------------------------------------------------
15724 # The output directory is defined with the -o option.
15725 #------------------------------------------------------------------------------
15727 $outputdir = $g_user_settings{"output"}{"current_value"};
15729 elsif ($overwrite_output_dir)
15730 #------------------------------------------------------------------------------
15731 # The output directory is defined with the -O option.
15732 #------------------------------------------------------------------------------
15734 $outputdir = $g_user_settings{"overwrite"}{"current_value"};
15737 #------------------------------------------------------------------------------
15738 # The name of the output directory is known and we can proceed.
15739 #------------------------------------------------------------------------------
15740 $msg = "the target output directory is $outputdir";
15741 gp_message
("debug", $subr_name, $msg);
15745 #------------------------------------------------------------------------------
15746 # The -o option is used, but the directory already exists.
15747 #------------------------------------------------------------------------------
15748 if ($define_new_output_dir)
15750 $msg = "directory $outputdir already exists";
15751 gp_message
("error", $subr_name, $msg);
15752 $msg = "use the -O/--overwite option to overwrite an";
15753 $msg .= " existing directory";
15754 gp_message
("error", $subr_name, $msg);
15756 $g_total_error_count++;
15758 gp_message
("abort", $subr_name, $g_abort_msg);
15761 elsif ($overwrite_output_dir)
15762 #------------------------------------------------------------------------------
15763 # It is a bit risky to remove this directory and so we proceed with caution.
15764 # What if the user decides to call it "*" e.g. "-O \*" for example? While this
15765 # should have been caught when processing the options, we still like to
15766 # be very cautious here before executing /bin/rm -rf.
15767 #------------------------------------------------------------------------------
15769 if ($outputdir eq "*")
15771 $msg = "it is not allowed to use * as a value for the -O option";
15772 gp_message
("error", $subr_name, $msg);
15774 $g_total_error_count++;
15776 gp_message
("abort", $subr_name, $g_abort_msg);
15780 #------------------------------------------------------------------------------
15781 # The output directory exists, but it is okay to overwrite it. It is
15782 # removed here and created again below.
15783 #------------------------------------------------------------------------------
15784 $target_cmd = $g_mapped_cmds{"rm"} . " -rf " . $outputdir;
15785 ($error_code, $rm_output_msg) = execute_system_cmd
($target_cmd);
15787 if ($error_code != 0)
15789 $msg = "fatal error when trying to remove $outputdir";
15790 gp_message
("error", $subr_name, $rm_output_msg);
15791 gp_message
("error", $subr_name, $msg);
15793 $g_total_error_count++;
15795 gp_message
("abort", $subr_name, $g_abort_msg);
15799 $msg = "directory $outputdir has been removed";
15800 gp_message
("debug", $subr_name, $msg);
15804 } #-- End of if-check for $outputdir
15806 #------------------------------------------------------------------------------
15807 # When we get here, the fatal scenarios have not occurred and the name for
15808 # $outputdir is known. Time to create it. Note that recursive creation is
15809 # supported and the user umask settings control the access permissions.
15810 #------------------------------------------------------------------------------
15811 $target_cmd = $g_mapped_cmds{"mkdir"} . " -p " . $outputdir;
15812 ($error_code, $mkdir_output_msg) = execute_system_cmd
($target_cmd);
15814 if ($error_code != 0)
15816 $msg = "a fatal problem occurred when creating directory $outputdir";
15817 gp_message
("error", $subr_name, $mkdir_output_msg);
15818 gp_message
("error", $subr_name, $msg);
15820 $g_total_error_count++;
15822 gp_message
("abort", $subr_name, $g_abort_msg);
15826 $msg = "created output directory $outputdir";
15827 gp_message
("debug", $subr_name, $msg);
15830 return ($outputdir);
15832 } #-- End of subroutine set_up_output_directory
15834 #------------------------------------------------------------------------------
15835 # Routine to generate webfriendly names
15836 #------------------------------------------------------------------------------
15839 my $subr_name = get_my_name
();
15841 my ($target_name) = @_;
15843 #------------------------------------------------------------------------------
15844 # Keeps track how many names have been tagged already.
15845 #------------------------------------------------------------------------------
15846 state $S_total_tagged_names = 0;
15851 gp_message
("debug", $subr_name, "target_name on entry = $target_name");
15853 #------------------------------------------------------------------------------
15854 # Undo conversion of < in to <
15855 #------------------------------------------------------------------------------
15857 #------------------------------------------------------------------------------
15858 # TBD: Legacy - What is going on here and is this really needed?!
15859 # We need to replace the "<" symbol in the code by "<".
15860 #------------------------------------------------------------------------------
15861 $target_name =~ s/$g_html_less_than_regex/$g_less_than_regex/g;
15863 #------------------------------------------------------------------------------
15864 # Remove inlining info
15865 #------------------------------------------------------------------------------
15866 $target_name =~ s/, instructions from source file.*//;
15868 if (defined $g_tagged_names{$target_name})
15870 $msg = "target_name = $target_name is already defined: ";
15871 $msg .= $g_tagged_names{$target_name};
15872 gp_message
("debug", $subr_name, $msg);
15874 $msg = "target_name on return = $target_name";
15875 gp_message
("debug", $subr_name, $msg);
15877 return ($g_tagged_names{$target_name});
15881 $unique_name = "ftag".$S_total_tagged_names;
15882 $S_total_tagged_names++;
15883 $g_tagged_names{$target_name} = $unique_name;
15885 $msg = "target_name = $target_name is new and added: ";
15886 $msg .= "g_tagged_names{$target_name} = $g_tagged_names{$target_name}";
15887 gp_message
("debug", $subr_name, $msg);
15889 $msg = "target_name on return = $target_name";
15890 gp_message
("debug", $subr_name, $msg);
15892 return ($unique_name);
15895 } #-- End of subroutine tag_name
15897 #------------------------------------------------------------------------------
15898 # Generate a string to terminate the HTML document.
15899 #------------------------------------------------------------------------------
15900 sub terminate_html_document
15902 my $subr_name = get_my_name
();
15906 $html_line = "</body>\n";
15907 $html_line .= "</html>";
15909 return (\
$html_line);
15911 } #-- End of subroutine terminate_html_document
15913 #------------------------------------------------------------------------------
15914 # Perform some basic checks to ensure the input data is consistent. This part
15915 # could be refined and expanded over time. For example by using a checksum
15916 # mechanism to verify the consistency of the executables.
15917 #------------------------------------------------------------------------------
15918 sub verify_consistency_experiments
15920 my $subr_name = get_my_name
();
15922 my ($exp_dir_list_ref) = @_;
15924 my @exp_dir_list = @
{ $exp_dir_list_ref };
15926 my $executable_name;
15927 my $full_path_executable_name;
15929 my $ref_executable_name;
15931 my $first_exp_dir = $TRUE;
15932 my $count_differences = 0;
15934 #------------------------------------------------------------------------------
15935 # Enforce that the full path names to the executable are the same. This could
15936 # be overkill and a checksum approach would be more flexible.
15937 #------------------------------------------------------------------------------
15938 for my $full_exp_dir (@exp_dir_list)
15940 my $exp_dir = get_basename
($full_exp_dir);
15941 gp_message
("debug", $subr_name, "exp_dir = $exp_dir");
15942 if ($first_exp_dir)
15944 $first_exp_dir = $FALSE;
15945 $ref_executable_name =
15946 $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
15947 $msg = "ref_executable_name = " . $ref_executable_name;
15948 gp_message
("debug", $subr_name, $msg);
15951 $full_path_executable_name =
15952 $g_exp_dir_meta_data{$exp_dir}{"full_path_exec"};
15953 $msg = "full_path_executable_name = " . $full_path_executable_name;
15954 gp_message
("debug", $subr_name, $msg);
15956 if ($full_path_executable_name ne $ref_executable_name)
15958 $count_differences++;
15959 $msg = $full_path_executable_name . " does not match";
15960 $msg .= " " . $ref_executable_name;
15961 gp_message
("debug", $subr_name, $msg);
15965 $executable_name = get_basename
($ref_executable_name);
15967 return ($count_differences, $executable_name);
15969 } #-- End of subroutine verify_consistency_experiments
15971 #------------------------------------------------------------------------------
15972 # Check if the input item is valid for the data type specified. Validity is
15973 # verified in the context of gprofng. The definition for the metrics is a
15974 # good example of that.
15975 #------------------------------------------------------------------------------
15976 sub verify_if_input_is_valid
15978 my $subr_name = get_my_name
();
15980 my ($input_item, $data_type) = @_;
15983 my $return_value = $FALSE;
15985 #------------------------------------------------------------------------------
15986 # These value are allowed to be case insensitive, so we convert to lower
15988 #------------------------------------------------------------------------------
15989 if (($data_type eq "onoff") or ($data_type eq "size"))
15991 $input_item = lc ($input_item);
15994 if ($data_type eq "metrics")
15995 #------------------------------------------------------------------------------
15996 # A gprofng metric definition. Either consists of "default" only, or starts
15997 # with e or i, followed by one or more from the set {.,%,!,+} and a keyword.
15998 # This pattern may be repeated with a ":" as the separator.
15999 #------------------------------------------------------------------------------
16001 my @metric_list = split (":", $input_item);
16003 #------------------------------------------------------------------------------
16004 # Check if the pattern is valid. If not, bail out and return $FALSE.
16005 #------------------------------------------------------------------------------
16006 for my $metric (@metric_list)
16008 if ($metric =~ /^default$|^[ei]*[\.%\!\+]+[a-z]*$/)
16010 $return_value = $TRUE;
16014 $return_value = $FALSE;
16019 elsif ($data_type eq "metric_names")
16020 #------------------------------------------------------------------------------
16021 # A gprofng metric definition but without the flavour and visibility . Either
16022 # the name consists of "default" only, or a keyword with lowercase letters
16023 # only. This pattern may be repeated with a ":" as the separator.
16024 #------------------------------------------------------------------------------
16026 my @metric_list = split (":", $input_item);
16028 #------------------------------------------------------------------------------
16029 # Check if the pattern is valid. If not, bail out and return $FALSE.
16030 #------------------------------------------------------------------------------
16031 for my $metric (@metric_list)
16033 if ($metric =~ /^default$|^[a-z]*$/)
16035 $return_value = $TRUE;
16039 $return_value = $FALSE;
16044 elsif ($data_type eq "path")
16045 #------------------------------------------------------------------------------
16046 # This can be almost anything, including "/" and "."
16047 #------------------------------------------------------------------------------
16049 if ($input_item =~ /^[\w\/\
.\
-]*$/)
16051 $return_value = $TRUE;
16054 elsif ($data_type eq "boolean")
16056 #------------------------------------------------------------------------------
16057 # This is TRUE (=1) or FALSE (0).
16058 #------------------------------------------------------------------------------
16059 if ($input_item =~ /^[01]$/)
16061 $return_value = $TRUE;
16064 elsif ($data_type eq "onoff")
16065 #------------------------------------------------------------------------------
16066 # This is either "on" OR "off".
16067 #------------------------------------------------------------------------------
16069 if ($input_item =~ /^on$|^off$/)
16071 $return_value = $TRUE;
16074 elsif ($data_type eq "size")
16075 #------------------------------------------------------------------------------
16076 # Supported values are "on", "off", "s", "m", "l", or "xl".
16077 #------------------------------------------------------------------------------
16079 if ($input_item =~ /^on$|^off$|^s$|^m$|^l$|^xl$/)
16081 $return_value = $TRUE;
16084 elsif ($data_type eq "pinteger")
16085 #------------------------------------------------------------------------------
16086 # This is a positive integer.
16087 #------------------------------------------------------------------------------
16089 if ($input_item =~ /^\d*$/)
16091 $return_value = $TRUE;
16094 elsif ($data_type eq "integer")
16095 #------------------------------------------------------------------------------
16096 # This is a positive or negative integer.
16097 #------------------------------------------------------------------------------
16099 if ($input_item =~ /^\-?\d*$/)
16101 $return_value = $TRUE;
16104 elsif ($data_type eq "pfloat")
16105 #------------------------------------------------------------------------------
16106 # This is a positive floating point number, but we accept a positive integer
16109 # TBD: Note that we use the "." here. Maybe should support a "," too.
16110 #------------------------------------------------------------------------------
16112 if (($input_item =~ /^\d*\.\d*$/) or ($input_item =~ /^\d*$/))
16114 $return_value = $TRUE;
16117 elsif ($data_type eq "float")
16118 #------------------------------------------------------------------------------
16119 # This is a positive or negative floating point number, but we accept an
16120 # integer number as well.
16122 # TBD: Note that we use the "." here. Maybe should support a "," too.
16123 #------------------------------------------------------------------------------
16125 if (($input_item =~ /^\-?\d*\.\d*$/) or ($input_item =~ /^\-?\d*$/))
16127 $return_value = $TRUE;
16132 $msg = "the $data_type data type for input $input_item is not supported";
16133 gp_message
("assertion", $subr_name, $msg);
16136 return ($return_value);
16138 } #-- End of subroutine verify_if_input_is_valid
16140 #------------------------------------------------------------------------------
16141 # Scan the leftovers in ARGV. Other than the option generated by the driver,
16142 # this list should be empty. Anything left here is considered to be a fatal
16143 # error and pushed into the g_error_msgs buffer.
16145 # We use two different arrays for the errors found. This allows us to group
16146 # the same type of errors.
16147 #------------------------------------------------------------------------------
16148 sub wrap_up_user_options
16150 my $subr_name = get_my_name
();
16152 my @opt_unsupported = ();
16153 my @opt_ignored = ();
16155 my $current_option;
16156 my $driver_inserted = "--whoami=gprofng display html";
16159 my $option_delimiter = "--";
16163 $msg = "items in ARGV: " . join (" ", @ARGV);
16164 gp_message
("debugXL", $subr_name, $msg);
16166 $ignore_option = $FALSE;
16167 for my $i (keys @ARGV)
16169 $current_option = $ARGV[$i];
16171 $msg = "ARGV[$i] = $current_option";
16173 if ($current_option eq $option_delimiter)
16174 #------------------------------------------------------------------------------
16175 # The user may use a feature of GetOptions to delimit the options. After
16176 # this, only experiment names are allowed and these have been handled already,
16177 # so anything found after this delimite is an error.
16179 # This is why we set a flag if the delimiter has been found.
16180 #------------------------------------------------------------------------------
16182 $ignore_option = $TRUE;
16183 gp_message
("debugXL", $subr_name, $msg . " (option delimiter)");
16185 elsif ($ignore_option)
16186 #------------------------------------------------------------------------------
16187 # We have seen the delimiter, but there are still options, or other strings.
16188 # In any case, it is not allowed.
16189 #------------------------------------------------------------------------------
16191 push (@opt_ignored, $current_option);
16192 gp_message
("debugXL", $subr_name, $msg . " (ignored)");
16194 elsif ($current_option ne $driver_inserted)
16195 #------------------------------------------------------------------------------
16196 # The gprofng driver inserts this and it should be ignored. This is why we
16197 # only recorded those options different than the one inserted by the driver.
16198 #------------------------------------------------------------------------------
16200 push (@opt_unsupported, $current_option);
16201 gp_message
("debugXL", $subr_name, $msg . " (unsupported)");
16204 #------------------------------------------------------------------------------
16205 # The gprofng driver inserts this option and it should be ignored.
16206 #------------------------------------------------------------------------------
16208 gp_message
("debugXL", $subr_name, $msg .
16209 " (driver inserted and ignored)");
16214 #------------------------------------------------------------------------------
16215 # Store any illegal input in the g_error_msgs buffer.
16216 #------------------------------------------------------------------------------
16219 $msg = "the following input is out of place:";
16220 for my $i (keys @opt_ignored)
16222 $msg .= " " . $opt_ignored[$i];
16224 gp_message
("error", $subr_name, $msg);
16226 $g_total_error_count++;
16228 if (@opt_unsupported)
16230 $msg = "the following items in the input are not supported:";
16231 for my $i (keys @opt_unsupported)
16233 $msg .= " " . $opt_unsupported[$i];
16235 gp_message
("error", $subr_name, $msg);
16237 $msg = "perhaps an error in the option name, or an option value";
16238 $msg .= " is missing?";
16239 gp_message
("error", $subr_name, $msg);
16241 $g_total_error_count++;
16246 } #-- End of subroutine wrap_up_user_options