#!/usr/bin/perl -w



################################################################################
##
## Copyright (c) 2007 Intel Corporation 
## All rights reserved. 
##
## Redistribution and use in source and binary forms, with or without 
## modification, are permitted provided that the following conditions are met: 
##
## * Redistributions of source code must retain the above copyright notice, 
## this list of conditions and the following disclaimer. 
## * Redistributions in binary form must reproduce the above copyright notice, 
## this list of conditions and the following disclaimer in the documentation 
## and/or other materials provided with the distribution. 
## * Neither name of Intel Corporation nor the names of its contributors 
## may be used to endorse or promote products derived from this software 
## without specific prior written permission.
## 
## THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 
## "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 
## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
## A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL INTEL OR 
## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
## EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 
## PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 
## PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY 
## OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
## NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
## SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
################################################################################

#
# Read the simple text version of the SEGV trace and convert it into summary statistics,
# or read the binary versions of the same information.
#
# Based on Jeff's version, but turned around so that we can defer running addr2line
# until the end so that we can batch up all of the conversion into one call to 
# addr2line, thus only parsing the debug information once, rather than once per line.
#
use strict;
use warnings;

use Getopt::Long;
use Pod::Usage;
use IO::Handle;
use IO::File;

# ------------------------------------

# Issue a warning if HTML::Entities module is not found, but continue working.
sub _encode_entities() {
    return @_;
}; # sub _encode_entities

eval( "use HTML::Entities;" );
if ( $@ ) {
    warn( "HTML::Entities module not found\n" );
    *encode_entities = \&_encode_entities;
}; # if

# ------------------------------------

our $VERSION = "1.1";

# Each of these hashes is indexed by node:PC address

# This is indexed by the region name
# Each entry is a reference to a hash with members "Aggregate of all" and the
# other statistics which come from that region (each of which is itself
# a reference to a hash)
my %statistics = ();

# A simple hash based solely on the PC, ignoring the node.
# There is no content here, the useful thing is the set of keys
# We're using a hash just to uniq the set.
my %seen_pcs = ();

# This is indexed by PC.
my %addr_to_line = ();

# Maximum width of a function name.
my $max_function_width = 0;
# Maximum width of a hex encoded program counter.
my $max_pc_width      = 0;

# Library name to load offset
my %shared_lib_addrs = ();

# Trace support
my @trace = ();

# The name we use for the accumulated total in each set of statistics.
# This is treated specially by the sort for statistics so that it always
# sorts to the top.

my $total_name = "Total";
my $whole_program_name = "Whole Program";

# Whether to print full path names in line information.
my $fullpath = 0;
# Don't print stats for things which contribute less than this.
my $threshold = 50;
# Whether to show per node information
my $by_nodes = 0;
# Whether to aggregate the statistics by line (default), or by PC.
my $by_lines = 0;

sub add_to_hash($$$$)
{
    my ($hash_ref, $count, $node, $pc)  = @_;

    $seen_pcs{$pc} = 1;
    my $key = $by_nodes ? "$node-$pc" : $pc;
    $$hash_ref{$key} += $count;
}

sub print_type($$)
{
    my ($title, $hash_ref) = @_;

    # If there's no data don't print anything. */
    return unless (%$hash_ref);
    
    my $printed_title = 0;

    print ("$title:\n");

    my $body_line_format =  $by_nodes ? 
	"%10s %5s 0x%0".($max_pc_width-2)."lx %-".$max_function_width."s %s\n" :
	"%10s 0x%0".($max_pc_width-2)."lx %-".$max_function_width."s %s\n" ;

    my $grandtotal = 0;
    my $thresholded = 0;
    my $threshold_bins = 0;

    foreach my $key (sort { $$hash_ref{$b} <=> $$hash_ref{$a} } keys(%$hash_ref))
    {
	my $count = $$hash_ref{$key};
	$grandtotal += $count;

	if ($count < $threshold){
	    $thresholded += $count;
	    $threshold_bins++;
	    next;
	}

	my ($node, $addr);
	if ($by_nodes){
	    ($node, $addr) = ($key =~ /(.*)-(.*)/);
	}else{
	    $addr = $key;
	}

	my ($function, $srcloc) = ("", "");

	if ($addr_to_line{$addr}){
	    $function = $addr_to_line{$addr}{'function'};
	    $srcloc   = $addr_to_line{$addr}{'srcloc'};
	}

	if ($by_nodes){
	    if (!$printed_title){
		my $title_line_format = "%10s %5s %-".$max_pc_width."s %-".$max_function_width."s %s\n";
		printf  ($title_line_format, "Count", "Proc", "PC address", "Function","Source Location/Library");
		$printed_title++;

 		# Print table head in case --proc specified (--pc specified); sortable table: class="sortable"
		print (REG "<TABLE class=\"sortable\" BORDER=\"1\" CELLSPACING=\"1\" CELLPADDING=\"4\" ALIGN=\"center\">\n");
        	print (REG "<THEAD>\n");
        	print (REG "<TR ID=grey>\n");
        	print (REG "<TH>Count</TH>\n");
        	print (REG "<TH>Proc</TH>\n");
        	print (REG "<TH>PC address</TH>\n");
        	print (REG "<TH>Function</TH>\n");
        	print (REG "<TH>Source Location/Library</TH>\n");
        	print (REG "</TR>\n");
        	print (REG "</THEAD>\n");
		print (REG "<TBODY>\n");
	    }
    	    {
        	# Warnings disabled here because on 64-bit system the warning about non-portable hexadecimal appears
        	no warnings;
		printf ($body_line_format, $count, $node, hex($addr), $function, $srcloc);
    	    }

 	    # Print table body in case --proc specified (--pc specified)
	    print (REG "<TR>\n");
            print (REG "<TD class=R>$count</TD>\n");
            print (REG "<TD class=R>$node</TD>\n");
            print (REG "<TD class=R>$addr</TD>\n");
            print (REG "<TD class=L>$function</TD>\n");
	    my @name = split /:/, $srcloc;
	    my $file = $name[0];
	    # Check if it is a source file and it is readable then create the link to html-file with the source
	    if ($srcloc =~ m/\.c|\.f|\.h/ && -r $file){
		$file =~ s/\/|\./_/g;
#        	print (REG "<TD ALIGN=\"left\"><a href=\"./$file\_fr.html\">$srcloc</a></TD>\n");
        	print (REG "<TD class=L><a href=\"./$file\_fr.html\">$name[0]</a>:$name[1]</TD>\n");
	    }
	    else{ # It is not a source file i.e. library then no link to source.
	    	print (REG "<TD class=L>$srcloc</TD>\n");
	    }
    	    print (REG "</TR>\n");
	}else{
	    if (!$printed_title){
		my $title_line_format = "%10s %-".$max_pc_width."s %-".$max_function_width."s %s\n";
		printf  ($title_line_format, "Count", "PC address", "Function","Source Location/Library");
		$printed_title++;

		# Print table head in case NO --proc (--pc specified); sortable table: class="sortable"
		print (REG "<TABLE class=\"sortable\" BORDER=\"1\" CELLSPACING=\"1\" CELLPADDING=\"4\" ALIGN=\"center\">\n");
        	print (REG "<THEAD>\n");
        	print (REG "<TR ID=grey>\n");
        	print (REG "<TH>Count</TH>\n");
        	print (REG "<TH>PC address</TH>\n");
        	print (REG "<TH>Function</TH>\n");
        	print (REG "<TH>Source Location/Library</TH>\n");
        	print (REG "</TR>\n");
        	print (REG "</THEAD>\n");
		print (REG "<TBODY>\n");
	    }
    	    {
        	# Warnings disabled here because on 64-bit system the warning about non-portable hexadecimal appears
        	no warnings;
		printf ($body_line_format, $count, hex($addr), $function, $srcloc);
	    }
	    # Print table body in NO --proc (--pc specified)
	    print (REG "<TR>\n");
            print (REG "<TD class=R>$count</TD>\n");
            print (REG "<TD class=R>$addr</TD>\n");
            print (REG "<TD class=L>$function</TD>\n");
	    my @name = split /:/, $srcloc;
	    my $file = $name[0];
	    # Check if it is a source file and it is readable then create a link to html file with the source
	    if ($srcloc =~ m/\.c|\.f|\.h/ && -r $file){
		$file =~ s/\/|\./_/g;
#        	print (REG "<TD ALIGN=\"left\"><a href=\"./$file\_fr.html\">$srcloc</a></TD>\n");
        	print (REG "<TD class=L><a href=\"./$file\_fr.html\">$name[0]</a>:$name[1]</TD>\n");
	    }else{ # It is not a source file then no link to source
	    	print (REG "<TD class=L>$srcloc</TD>\n");
	    }
	}
    }
    if ($thresholded){
	my $locs = $threshold_bins > 1 ? "locations" : "location";
	printf  ("%10i (%i%%) at $threshold_bins $locs below the threshold of $threshold.\n",$thresholded,
	100*$thresholded/$grandtotal);

	my $tmp = sprintf ("%10i (%i%%) at $threshold_bins $locs below the threshold of $threshold.",$thresholded,
	100*$thresholded/$grandtotal);
	if ($printed_title){
	    print (REG "</TBODY>\n");
	    print (REG "<TFOOt>\n");
	    print (REG "<TR class=\"sortbottom\">\n");
	    print (REG "<TD COLSPAN=\"5\">$tmp</TD>\n");
	    print (REG "</TR>\n");
	    print (REG "</TFOOt>\n");
	    print (REG "</TABLE>\n");
	}else{
	    print (REG "$tmp\n");
	}    
    }else{
	print (REG "</TBODY>\n");
	print (REG "</TABLE>\n");
    }
    printf ("%10i Grand Total\n\n", $grandtotal);
    return $grandtotal;
}

sub print_accumulated($$)
{
    my ($title, $hash_ref) = @_;

    # If there's no data don't print anything. */
    return unless (%$hash_ref);
    
    my $printed_title = 0;

    print "$title:\n";

    my $body_line_format =  $by_nodes ? 
	"%10s %5s %-".$max_function_width."s %s\n" :
	"%10s %-".$max_function_width."s %s\n" ;
    my $grandtotal = 0;
    my $thresholded = 0;
    my $threshold_bins = 0;

    foreach my $key (sort { $$hash_ref{$b} <=> $$hash_ref{$a} } keys(%$hash_ref)){
	my $count = $$hash_ref{$key};
	$grandtotal += $count;

	if ($count < $threshold){
	    $thresholded += $count;
	    $threshold_bins++;
	    next;
	}

	my ($node, $function, $srcloc);
	if ($by_nodes){
	    ($node, $function, $srcloc) = split /-/, $key;
	}else{
	    ($function, $srcloc) = split /-/, $key;
	}

	if ($by_nodes){ # --proc specified
	    if (!$printed_title){
		my $title_line_format = "%10s %5s %-".$max_function_width."s %s\n";
		printf  ($title_line_format, "Count", "Proc", "Function","Source Location/Library");
		$printed_title++;
	        
		# Print table head in case --proc specified (--pc NOT  specified); sortable table: class="sortable"
		print (REG "<TABLE class=\"sortable\" BORDER=\"1\" CELLSPACING=\"1\" CELLPADDING=\"4\" ALIGN=\"center\">\n");
        	print (REG "<THEAD>\n");
        	print (REG "<TR ID=grey>\n");
        	print (REG "<TH>Count</TH>\n");
        	print (REG "<TH>Proc</TH>\n");
        	print (REG "<TH>Function</TH>\n");
        	print (REG "<TH>Source Location/Library</TH>\n");
        	print (REG "</TR>\n");
        	print (REG "</THEAD>\n");
		print (REG "<TBODY>\n");
	    }
	    printf ($body_line_format, $count, $node, $function, $srcloc);

	    # Print table body in case --proc specified (--pc NOT specified)
	    print (REG "<TR>\n");
            print (REG "<TD class=R>$count</TD>\n");
            print (REG "<TD class=R>$node</TD>\n");
            print (REG "<TD class=L>$function</TD>\n");
	    my @name = split /:/, $srcloc;
	    my $file = $name[0];
	    # Check if it is a source file ad it is readable  then create a link to html file with the source
	    if ($srcloc =~ m/\.c|\.f|\.h/ && -r $file){
		$file =~ s/\/|\./_/g;
#        	print (REG "<TD ALIGN=\"left\"><a href=\"./$file\_fr.html\">$srcloc</a></TD>\n");
        	print (REG "<TD class=L><a href=\"./$file\_fr.html\">$name[0]</a>:$name[1]</TD>\n");
	    }else{ # it is not a source file -library -  so no link to the source
	    	print (REG "<TD class=L>$srcloc</TD>\n");
	    }
    	    print (REG "</TR>\n");
	}else{# --proc NOT specified
	    if (!$printed_title){
		my $title_line_format = "%10s %-".$max_function_width."s %s\n";
		printf  ($title_line_format, "Count", "Function","Source Location/Library");
		$printed_title++;

		# Print table head in case NO --proc (--pc NOT specified); sortable table: class="sortable"
		print (REG "<TABLE class=\"sortable\" BORDER=\"1\" CELLSPACING=\"1\" CELLPADDING=\"4\" ALIGN=\"center\">\n");
        	print (REG "<THEAD>\n");
        	print (REG "<TR ID=grey>\n");
        	print (REG "<TH>Count</TH>\n");
        	print (REG "<TH>Function</TH>\n");
        	print (REG "<TH>Source Location/Library</TH>\n");
        	print (REG "</TR>\n");
        	print (REG "</THEAD>\n");
		print (REG "<TBODY>\n");
	    }
	    printf ($body_line_format, $count, $function, $srcloc);

	    # Print table body in case NO  --proc specified (--pc NOT specified)
	    print (REG "<TR>\n");
            print (REG "<TD class=R>$count</TD>\n");
            print (REG "<TD class=L>$function</TD>\n");
	    my @name = split /:/, $srcloc;
	    my $file = $name[0];
	    if ($srcloc =~ m/\.c|\.f|\.h/ && -r $file){
		$file =~ s/\/|\./_/g;
#        	print (REG "<TD ALIGN=\"left\"><a href=\"./$file\_fr.html\">$srcloc</a></TD>\n");
        	print (REG "<TD class=L><a href=\"./$file\_fr.html\">$name[0]</a>:$name[1]</TD>\n");
	    }else{ # It is not a source file then no link to source
	    	print (REG "<TD class=L>$srcloc</TD>\n");
	    }
	    print (REG "</TR>\n");
	}
    }
    if ($thresholded){
	my $locs = $threshold_bins > 1 ? "locations" : "location";
	printf  ("%10i (%i%%) at $threshold_bins $locs below the threshold of $threshold.\n",$thresholded,
	100*$thresholded/$grandtotal);

	my $tmp = sprintf ("%10i (%i%%) at $threshold_bins $locs below the threshold of $threshold.",$thresholded, 
	100*$thresholded/$grandtotal);
	if ($printed_title){
	    print (REG "</TBODY>\n");
	    print (REG "<TFOOT>\n");
	    print (REG "<TR class=\"sortbottom\">\n");
	    print (REG "<TD COLSPAN=\"5\">$tmp</TD>\n");
	    print (REG "</TR>\n");
	    print (REG "</TFOOT>\n");
	    print (REG "</TABLE>\n");
	}else{
	    print (REG "$tmp\n");
	}
    }else{
        print (REG "</TBODY>\n");
	print (REG "</TABLE>\n");
    }
    printf ("%10i Grand Total\n\n", $grandtotal);
    return $grandtotal;		
}

sub print_trace()
{
    if ($#trace > 0){
	my $old_ip = 0;
	my $old_proc = -1;
	my $old_type = -1;
	my $new_page = -1;
	my $page_low = -1;
	my $page_high = -1;
	my $width = $max_function_width + 4;
	print ("Trace:\n");
	my $line_format = "%-5s %5s %-15s 0x%08x  %-".$width."s %s\n";
	my $string_format = "%-5s %5s %-15s %-".$max_pc_width."s  %-".$width."s %s\n";

	printf ($string_format,"Proc", "Type", "Page", "PC address", "Function", "Source Location");

	foreach my $entry (@trace){
	   
	    my ($proc, $type, $page, $ip) = split /-/, $entry;
	    my ($function, $srcloc) = ("", "");

	    if ($old_proc != $proc || $old_ip != $ip || $type != $old_type || abs($page - $new_page) > 1){
		if ($addr_to_line{$ip}){
		    $function = $addr_to_line{$old_ip}{'function'};
		    $srcloc   = $addr_to_line{$old_ip}{'srcloc'};
		}
    		{
        	    # Warnings disabled here because on 64-bit system the warning about non-portable hexadecimal appears
        	    no warnings;
		    if ($page_low != -1){
			if ($page_low == $page_high){
			    printf ($line_format, $old_proc, $old_type, $page_low, hex($old_ip), $function, $srcloc);
			}else {
			    printf ($line_format, $old_proc, $old_type, $page_low."-".$page_high, hex($old_ip), $function, $srcloc);
			}
		    }
		}
		$old_ip = $ip;
		$old_proc = $proc;
		$old_type = $type;
		$page_low = $page_high = $page;
	    }

	    $new_page = $page;
	    if ($page > $page_high){
	       $page_high = $page;
	    }
	    if ($page < $page_low){
	       $page_low = $page;
	    }
	}
	print ("\n\n");
    }
}

sub load_ascii_file($)
{
    my $file = shift;

    open(ADDRS, "<$file") || die("Could not open $file: $!\n");
    my $region = $whole_program_name;
    $statistics{$region} = {"Write SEGVs" => {},
			    "Fetch SEGVs" => {},
			    "Wait SEGVs"  => {},
			    $total_name => {} } unless ($statistics{$region});

    my $writesref  = $statistics{$region}->{"Write SEGVs"};
    my $fetchesref = $statistics{$region}->{"Fetch SEGVs"};
    my $waitsref   = $statistics{$region}->{"Wait SEGVs"};
    my $totalsref  = $statistics{$region}->{$total_name};

    while (<ADDRS>){
	if (/PTRACE PROC:(\d+) T:(\w) P:(\d+) IP:(\S+)/){
	    my ($proc, $type, $page, $ip) = ($1, $2, $3, $4);

    	    {
        	# Warnings disabled here because on 64-bit system the warning about non-portable hexadecimal appears
        	no warnings;
		$ip = sprintf ("0x%08lx", hex($ip));
	    }
	    $seen_pcs{$ip} = 1;

	    push @trace, "$proc-$type-$page-$ip";
	}elsif (/IP:(\S+) P:(\d+) wr:(\d+) f:(\d+) w:(\d+)/){
	    my ($ip, $proc, $writes, $fetches, $waits) = ($1, $2, $3, $4, $5);
            {
        	# Warnings disabled here because on 64-bit system the warning about non-portable hexadecimal appears
        	no warnings;
		$ip = sprintf ("0x%08lx", hex($ip));
	    }
	    my $total = $writes + $fetches + $waits;

	    add_to_hash($totalsref, $total, $proc, $ip);
	    add_to_hash($writesref, $writes,$proc, $ip) if ($writes > 0);
	    add_to_hash($fetchesref, $fetches, $proc, $ip) if ($fetches > 0);
	    add_to_hash($waitsref, $waits, $proc, $ip) if ($waits > 0);
	}
    }
    close(ADDRS) or die ("Cannot close file: $!\n");
}

#
# Read the contents of a gprof format file.
#

sub read_gprof_header()
{
    my $header;

# typedef struct 
# {
#     char gm_cookie[4];
#     int32_t gm_version;
#     char gm_pad[12];
# } gm_file_header;

    read PROF_FILE, $header, 20 or return 0;
    
    my ($magic, $version) = unpack "a4i", $header;

    return 0 unless ($magic eq "gmon");
    return 0 unless ($version eq 1);

    return 1;
}

sub skip_gprof_bins()
{
# typedef struct 
# {
#     uintptr_t  lowpc;
#     uintptr_t  highpc;
#     int32_t    num_bins;
#     int32_t    frequency;
#     char       name[15];
#     char       dim_abbrev;
# } gm_hist_header;

    my $header;
    read PROF_FILE, $header, 40 or return 0;

    my ($lopc, $highpc, $num_bins, $frequency, $name, $dim_abbrev) = unpack "QQiia15a",$header;
    
    $name =~ s/\c@//g;

    printf("Bins:\nRange: 0x%08lx:0x%08lx\nBincount: %i\nFrequency: %i\nName: %s\nAbbrev: %s\n",
    $lopc, $highpc, $num_bins, $frequency, $name, $dim_abbrev);
    seek PROF_FILE, 2*$num_bins, 1;

    return 1;
}

sub read_gprof_bb()
{
    my $header;

    read PROF_FILE, $header, 4 or return 0;

    my $bincount = unpack "i", $header;

    for (; $bincount; $bincount--){
	my $bb_entry;
	read PROF_FILE, $bb_entry, 16 or return 0;
	my ($pc, $count) = unpack "QQ", $bb_entry;
	printf ("0x%08lx : %i\n", $pc, $count);
    }

    return 1;
}

sub read_gprof_stat_at_addr($)
{
    my $node_id = shift;
    my $header;

    read PROF_FILE, $header, 68 or return 0;

    my ($bincount,$name) = unpack "La64", $header;
    $name =~ s/\c@//g;
    my $region = $whole_program_name;

    if ($name =~ /^([^:]+):(.*)$/){
	$region = ((lc $1) eq (lc $whole_program_name)) ? $whole_program_name : $1;
	$name = $2;
    }
    # Ensure the hashes we require exist.
    $statistics{$region}->{$name} = {} unless ($statistics{$region}->{$name});
    $statistics{$region}->{$total_name} = {} unless ($statistics{$region}->{$total_name});
    $statistics{$whole_program_name} = {} unless ($statistics{$whole_program_name});

    my $hashref = $statistics{$region}->{$name};
    my $totalsref = $statistics{$region}->{$total_name};
    my $wpref = ($region ne $whole_program_name) ? $statistics{$whole_program_name} : 0;

    if ($wpref){
	$wpref->{$total_name} = {} unless ($wpref->{$total_name});
	$wpref->{$name} = {} unless ($wpref->{$name});
    }

    for (; $bincount; $bincount--){
	my $stat_entry;
	read PROF_FILE, $stat_entry, 12 or return 0;
	my ($pc, $count) = unpack "QI", $stat_entry;
	my $ip = sprintf ("0x%08lx", $pc);
	add_to_hash($hashref, $count, $node_id, $ip);
	add_to_hash($totalsref, $count, $node_id, $ip);

	if ($wpref){
	    add_to_hash($wpref->{$total_name}, $count, $node_id, $ip);
	    add_to_hash($wpref->{$name},   $count, $node_id, $ip);
	}
    }
    return 1;
}

sub read_gprof_liblist()
{
    my $tmp;
    read PROF_FILE, $tmp, 8 or return 0;

    my ($bytes, $count) = unpack "II", $tmp;
    
    for (; $count; $count--){
	read PROF_FILE, $tmp, 10 or return 0;
	my ($load_addr, $stringlen) = unpack "QS", $tmp;
	read PROF_FILE, $tmp, $stringlen or return 0;
	my $string = unpack "a*", $tmp;

	$shared_lib_addrs{$string} = $load_addr;
    }
}

sub load_gprof_file($)
{
    my $filename = shift;
    my $result = 1;

    open (PROF_FILE, "<$filename") or return 0;
    # Shouldn't be required, but appears to be on some unix systems.
    binmode PROF_FILE;

    if (!read_gprof_header()){
	close (PROF_FILE) or die ("Cannot close file: $!\n");
	print ("Failed to read gprof header from $filename\n");
	return 0;
    }

    # Work out the node number from the filename.
    my $node = 0;
    if ($filename =~ /_([0-9]+)\.gmon$/){
	$node = $1;
    }

    my $what;
    while (read PROF_FILE, $what, 1){
	my $tag = unpack "c", $what;
	if ($tag == 0){ 
	    # GM_TIME_HISTOGRAM
	    skip_gprof_bins();
	}elsif ($tag == 1){
	    # GM_CALL_ARC
	}
	elsif ($tag == 2){ 
	    # GM_BASIC_BLOCK_COUNT
	    read_gprof_bb();
	}elsif ($tag == 3){ 
	    # GM_STAT_AT_ADDR
	    read_gprof_stat_at_addr ($node);
	}elsif ($tag == 4){
	    read_gprof_liblist();
	}
	else{
	    print ("Unknown record tag in file $tag\n");
	    $result = 0;
	    last;
	}
    }
    close (PROF_FILE) or die ("Cannot close file: $!\n");
    return $result;
}

sub find_lines($)
{
    my $exe = shift;

    if ( not -e $exe ) {
        warn( "File \"$exe\" not found.\n" );
        return;
    }; # if

#   Write a temp file with the addresses in it for input to addr2line
    open (ADDRS, ">/tmp/clomp_profile.$$") or die ("Cannot open tmp file: $!\n");

    my $load_offset = $shared_lib_addrs{$exe};
    my $pc;
    my @looked_up;

    foreach $pc (keys %seen_pcs){
	next if ($addr_to_line{$pc});		# We already know about this address

	$max_pc_width = length($pc) if (length($pc) > $max_pc_width);
#	my $pc_value = hex($pc);
	my $pc_value;
        {
            # Warnings disabled here because on 64-bit system the warning about non-portable hexadecimal appears
            no warnings;
            $pc_value = hex($pc);
        }
	next if ($pc_value < $load_offset);
	
	push @looked_up, $pc;

	$pc_value = $pc_value - $load_offset;
	printf (ADDRS "0x%08lx\n", $pc_value);
    }

    close(ADDRS) or die ("Cannot close file: $!\n");
    my $arg_flag = "-s";
    $arg_flag = "" if ($fullpath);

    open (ADDRS,"addr2line $arg_flag -f -C -e $exe < /tmp/clomp_profile.$$ |") or die ("Cannot start addr2line: $!");
=pod    
    open (LINES, "</tmp/clomp_profile.$$") or die ("Cannot open \"/tmp/clomp_profile.$$\" file: $!");
    open (ADDRS, ">/tmp/line_from_addr.$$") or die ("Cannot open \"/tmp/line_from_addr.$$\" file: $!");
    my $line_from_addr;
    while (my $getline = <LINES>){
#	$line_from_addr = `addr2line $arg_flag -f -C -e $exe $getline`;
#	print (ADDRS $line_from_addr);
	$getline =~s/\n//;
	system ("addr2line $arg_flag -f -C -e $exe $getline >>/tmp/line_from_addr.$$") == 0 or die ("Cannot execute addr2line: $?");
	my $exit_status = $? >> 8;
	my $signal_num = $? & 127;
	if ($signal_num){
	    print "addr2line failed due to signal $signal_num\n";
	    die;
	}
	if ($exit_status != 0) {
	    die ("addr2line execution failed\n");
	}
    }
#    close(ADDRS) or die ("Cannot close file: $!\n");
    close(LINES) or die ("Cannot close file: $!\n");

    open (ADDRS, "</tmp/line_from_addr.$$") or die ("Cannot open \"/tmp/line_from_addr.$$\" file: $!");
=cut
    $exe =~ s+.*/++;

    foreach $pc (@looked_up){
 	# We get a _pair_ of lines, a function and then a source location.
	$_ = <ADDRS>;
	last if (!defined $_);
	chomp;
	my $function = $_;
	$function = "" if ($function =~ /^[?][?]/);
	$function =~ s/ //g;

	$_ = <ADDRS>;
	last if (!defined $_);
	chomp;

	my $srcloc = $_;
	$srcloc = "" if ($srcloc =~ /^[?][?]/);

	next if ($srcloc eq "" && $function eq "");
	$srcloc =~ s/ //g;
	# If we don't have a source location show the shared library from which the function
	# came.
	$srcloc = $exe if ($srcloc eq "");

	$addr_to_line{$pc} = {'function' => $function, 'srcloc' => $srcloc};
	$max_function_width = length($function) if (length($function) > $max_function_width);

#	print ("$pc: '$addr_to_line{$pc}{'function'} $addr_to_line[$pc]{srcloc}'\n");
    }
    close (ADDRS) or die ("Cannot close file: $!\n");
    unlink "/tmp/clomp_profile.$$" ;
#    unlink "/tmp/line_from_addr.$$";
}

#
# Create a new set of stats in which the key is the line (or function if no line), rather
# than the PC. (This involves accumulating all of the PCs which map to the same line
# into a single new entry).
#
sub accumulate_by_line($)
{
    my $hash_ref = shift;
    my $result_ref = {};

    # If there's no data just return an empty hash
    return $result_ref unless (%$hash_ref);
    
    foreach my $key (keys(%$hash_ref)){
	my $count = $$hash_ref{$key};
	my ($node, $addr);
	if ($by_nodes){
	    ($node, $addr) = ($key =~ /(.*)-(.*)/);
	}else{
	    $addr = $key;
	}

	my ($function, $srcloc) = ("", "");

	if ($addr_to_line{$addr}){
	    $function = $addr_to_line{$addr}{'function'};
	    $srcloc   = $addr_to_line{$addr}{'srcloc'};
	}
	my $newkey = "$function-$srcloc";
	$newkey = "$node-$newkey" if ($by_nodes);

	$$result_ref{$newkey} = 0 unless ($$result_ref{$newkey});
	$$result_ref{$newkey} += $count;
    }
    return $result_ref;
}

#
# Sort criterion for region names. 
# We want a numeric sort of the embedded numeric components
# so that region #2 comes before region #10
#

sub by_region_name
{
    my ($aprefix, $anumeric) = split /#/, $a;
    my ($bprefix, $bnumeric) = split /#/, $b;

    return +1 if ($aprefix lt $bprefix);
    return -1 if ($aprefix gt $bprefix);

    # We're dealing with regions of the same kind.
    if (! ($anumeric =~ /,/)){
	return $anumeric <=> $bnumeric;
    }
    my ($ad1,$ad2) = ($anumeric =~ /([0-9]+),([0-9]+)/);
    my ($bd1,$bd2) = ($bnumeric =~ /([0-9]+),([0-9]+)/);

    return $ad1 <=> $bd1 if ($ad1 <=> $bd1);
    return $ad2 <=> $bd2;
}

# Sort based on the name of the statistic.
# We special case the name we use for the totals, so that it comes out first.
sub by_statistic
{
    return 0 if ($a eq $b);
    return -1 if ($a eq $total_name);
    return +1 if ($b eq $total_name);

    return $b cmp $a;
}

sub create_stat_array($%)
{
    my ($by_lines, %accumulated) = @_;
    my @segvs;
    if ($by_lines){
	foreach my $region (sort by_region_name keys %accumulated){
	    my $stat;
	    foreach $stat (sort by_statistic keys %{$accumulated{$region}}){
		my $exist = 0;
		foreach my $entry (@segvs){
		    if ($entry eq $stat){
			$exist = 1;
			last;
		    }
		}
		if ($exist == 0){
		    $segvs[++$#segvs]= $stat;
		}
	    }
	}
    }else {
        foreach my $region (sort by_region_name keys %statistics){
	    my $stat;
	    foreach $stat (sort by_statistic keys %{$statistics{$region}}){
		my $exist = 0;
		foreach my $entry (@segvs){
		    if ($entry eq $stat){
			$exist = 1;
			last;
		    }
		}
		if ($exist == 0){
		    $segvs[++$#segvs]= $stat;
		}
	    }
	}
    }
    return @segvs;
}

# --------------------------------------------------------------------------------------------------
# Main code starts here...
# --------------------------------------------------------------------------------------------------

my $exe = 0;
Getopt::Long::Configure ("no_ignore_case");
my $options_ok = GetOptions (
    'executable=s' => \$exe,
    'fullpath!'    => \$fullpath,
    'procs!'       => \$by_nodes,
    'threshold=s'  => \$threshold,
    'pc!'          => \$by_lines,
    "doc"          => sub { pod2usage( -verbose => 2, -exitval => 0 ); },
    "help"         => sub { pod2usage( -verbose => 1, -exitval => 0 ); },
    "usage"        => sub { pod2usage( -verbose => 0, -exitval => 0 ); },
    "version"      => sub { print( "segvprof version $VERSION\n" ); exit( 0 ); },
);
$by_lines = ! $by_lines;

pod2usage( -verbose => 0, -exitval => 0 ) if (!$exe || !@ARGV || 
					      !$options_ok || !($threshold =~ /^[0-9]+$/));

foreach my $filename (@ARGV){
    if ($filename =~ /\.gmon$/){
	load_gprof_file ($filename);
    }else{
	load_ascii_file ($filename);
    }
}

my $binary = 0;
$shared_lib_addrs{$exe} = 0;
foreach $binary (keys %shared_lib_addrs){
    find_lines ($binary);
}

print_trace();

# %accumulated hash creation moved here as well as the hash by sources and framed html-file for each source.
my %accumulated;
foreach my $region (keys %statistics){
    $accumulated{$region} = {};
    my $stat;
    foreach $stat (keys %{$statistics{$region}}){
        $accumulated{$region}->{$stat} = accumulate_by_line ($statistics{$region}->{$stat});
    }
}

# Create a hash by sources for the Whole Program region using %accumulated 
my %src_hash = ();
foreach my $stat_whole (sort by_statistic keys %{$accumulated{$whole_program_name}}){
    my $hash_ref = $accumulated{$whole_program_name}->{$stat_whole};
    foreach my $key (sort { $$hash_ref{$b} <=> $$hash_ref{$a} } keys(%$hash_ref)){
        my $count = $$hash_ref{$key};
        my ($node, $function, $srcloc);
        if ($by_nodes){
	    ($node, $function, $srcloc) = split /-/, $key;
	}else{
	    ($function, $srcloc) = split /-/, $key;
	}
	# split $srcloc into source path and line number
	my @name = split /:/, $srcloc;
	my $src_path = $name[0];
	my $line_number = $name[1];

	# Check if it is a source file and it is readable
	if ($srcloc =~ m/\.c|\.f|\.h/ && -r $src_path){
	    # Ensure the hashes we require exist.
	    $src_hash{$src_path}->{$stat_whole} = {} unless ($src_hash{$src_path}->{$stat_whole});
    	    my $ref = $src_hash{$src_path}->{$stat_whole};
	    my $newkey = "$function-$line_number";
	    $$ref{$newkey} = 0 unless ($$ref{$newkey});
	    $$ref{$newkey} += $count;
	}
    }
}

$exe =~ s/\.|\//_/g;
my $main_html = "SEGVprof_$exe";

# Create the directory for the html-files created for the specified executable
if (not -e $main_html){
    mkdir ($main_html) || die ("Cannot create \"SEGVprof_$exe\" directory: $!\n");
}
# Create style file and script from the __DATA__ (__END__)
my $name;
my $handle;
while ( my $line = DATA->getline() ) {
    if ( $line =~ m{\A--- (.*) ---\s*\n} ) {
        my $new_name = $1;
        if ( defined( $handle ) ) {
            $handle->close() or die ("Canot close file \"$main_html/$name\": $!\n");
        };
        if ( $new_name eq "end" ) {
            last;
        };
        $name = $new_name;
        $handle = IO::File->new( $main_html."/".$name, "w" ) or die ("Cannot open file \"$main_html/$name\": $!\n");
    } else {
        if ( defined( $handle ) ) {
            $handle->print( $line );
        } else {
            ( $line =~ m{\A\s*\n\z} ) or die ("Internal error");
        };
    };
};
DATA->close() or die ("Unexpected error");

# Create Main HTML file
open (HTML, ">./$main_html.html") or die ("Cannot open \"$main_html.html\" file: $!\n");
print (HTML "<HTML>\n");
print (HTML "<HEAD>\n");
print (HTML "<SCRIPT SRC=\"$main_html/sort_table.js\" TYPE=\"text/javascript\"></SCRIPT>\n");
print (HTML "<LINK rel=\"stylesheet\" href=\"$main_html/src_style.css\" type=\"text/css\" >\n");
print (HTML "<META http-equiv=\"Content-type\" content=\"text/html; charset =utf-8\"/>\n");
print (HTML "<TITLE>Cluster OpenMP SEGVprof Information</TITLE>\n");
print (HTML "</HEAD>\n");
print (HTML "<BODY>\n");
print (HTML "<H1>SEGVprof Region Summary Information</H1>\n");
#print (HTML "<H1 ALIGN=\"center\" STYLE=\"font-family:Arial,Helvetica;color:#3366ff\">SEGVprof Region Summary Information</H1>\n");

# Create framed html-file for each available source
foreach my $src (keys %src_hash){
    my $file = $src;
    $file =~ s/\/|\./_/g;

    open (SRCFRM, ">$main_html/$file\_fr.html") or die ("Cannot open \"$main_html/$file\_fr.html\" file: $!\n");
    print (SRCFRM "<HTML>\n");
    print (SRCFRM "<HEAD>\n");
    print (SRCFRM "<TITLE>Cluster OpenMP SEGVprof Information for $src</TITLE>\n");
    print (SRCFRM "</HEAD>\n");
    print (SRCFRM "<FRAMESET COLS=\"25%, *\">\n");

    # Create a single summary html-file for all segvs for the current source
    open (SUM, ">$main_html/$file\_sum.html") or die ("Cannot open \"$main_html/$file\_sum.html\" file: $!\n");
    print (SUM "<HTML>\n");
    print (SUM "<HEAD>\n");
    print (SUM "<SCRIPT SRC=\"sort_table.js\" TYPE=\"text/javascript\"></SCRIPT>\n");
    print (SUM "<LINK rel=\"stylesheet\" href=\"src_style.css\" type=\"text/css\" >\n");
    print (SUM "<META http-equiv=\"Content-type\" content=\"text/html; charset =utf-8\"/>\n");
    print (SUM "<TITLE>Cluster OpenMP SEGVprof Information for $src</TITLE>\n");
    print (SUM "<BASE TARGET=\"src_view\">\n");
    print (SUM "</HEAD>\n");
    print (SUM "<BODY>\n");
    print (SUM "<H4>SEGVs summary</H4>\n");
    	
    # Sortable table; class="sortable"    
    print (SUM "<TABLE CLASS=\"sum sortable\" BORDER=\"1\" CELLSPACING=\"1\" CELLPADDING=\"4\" ALIGN=\"left\">\n");
    print (SUM "<THEAD>\n");
    print (SUM "<TR>\n");
    print (SUM "<TH>Total</TH>\n");
    print (SUM "<TH>Write</TH>\n");
    print (SUM "<TH>Wait</TH>\n");
    print (SUM "<TH>Fetch</TH>\n");
    print (SUM "<TH>Function</TH>\n");
    print (SUM "</TR>\n");
    print (SUM "</THEAD>\n");
    print (SUM "<TBODY>\n");
    
    # Change the hash with segv type keys to a hash with function name keys
    my %func_hash=();
    my %segv_hash=%{$src_hash{$src}};
    foreach my $segv (sort by_statistic keys %segv_hash){
        my $ref = $segv_hash{$segv};
        foreach my $key (sort keys (%$ref)){
            my $count = $$ref{$key};
	    # Ensure the hashes we require exist.
	    $func_hash{$key} = {} unless ($func_hash{$key});
    	    my $new_ref = $func_hash{$key};
	    my $newkey = $segv;
	    $$new_ref{$newkey} = 0 unless ($$new_ref{$newkey});
	    $$new_ref{$newkey} += $count;
	}	
    }    
    my @segv_types = ("Total", "Write SEGVs", "Wait SEGVs", "Fetch SEGVs");
    my %line_colors = (); 
    # Fill in the source summary table
    foreach my $func (sort keys %func_hash)
    {
	if ($func_hash{$func}{"Total"} < $threshold) {
	    next;
	}
	(my $function, my $line) = split /-/, $func;
	print (SUM "<TR>\n");
	$line_colors{$line} = {} unless ($line_colors{$line});
	my $line_ref = $line_colors{$line};
	for (my $i = 0; $i <= $#segv_types; $i++){
            my $ref = $src_hash{$src}->{$segv_types[$i]};
	    my $max_count = 0;
    	    foreach my $key (sort { $$ref{$b} <=> $$ref{$a} } keys (%$ref)){
        	my $count = $$ref{$key};
		if(!$max_count){
		    $max_count += $count;
		}
		last;
	    }
	    if (exists ($func_hash{$func}{$segv_types[$i]})){
		my $count = $func_hash{$func}{$segv_types[$i]};
		# Show only values greater than the specified threshold ( = 50 by default, specify --threshold for another value)
		if ($count < $threshold){
		    print (SUM "<TD class=C class=empty>0</TD>\n");
		    $$line_ref{$segv_types[$i]}="white";
		}else{
		    print (SUM "<TD class=R>$count</TD>\n");
		    # Find a color for the $line 
		    my $color = "white";
		    my $ratio = 100*$count/$max_count;
		    my $percent = sprintf("%.0f", $ratio);
		    if($percent >= 80 && $percent <= 100){
			$color = "red";
		    }elsif($percent >= 60 && $percent <= 79){
			$color = "pink";
		    }elsif($percent >= 40 && $percent <= 59){
			$color = "orange";
		    }elsif($percent >= 20 && $percent <= 39){
			$color = "yellow";
		    }
		    $$line_ref{$segv_types[$i]} = $color;
		}
	    }else{
		print (SUM "<TD class=\"C empty\">0</TD>\n");
		$$line_ref{$segv_types[$i]}="white";
	    }
    	}
	# Shift line because of fixed header on a  source page; 4 is the header height (specified in css-file
	my $shift_line = $line - 4;
	print (SUM "<TD class=L><A href=$file\_src.html#l$shift_line>$function:$line</A></TD>\n");
	print (SUM "</TR>\n");
    }
    print (SUM "</TBODY>\n");
    print (SUM "</TABLE>\n");
    print (SUM "</BODY>\n");
    print (SUM "</HTML>\n");

    print (SRCFRM "<FRAME SRC=\"$file\_sum.html\" SCROLLING=\"yes\">\n");

    # Open the real source file to read it line-by-line
    open (SRC, "<$src") or die ("Cannot open source file $src: $!\n");
    # Create an html file with the source for this $segv type
    open (SRCHTML, ">$main_html/$file\_src.html") or die ("Cannot open \"$main_html/$file\_src.html\" file: $!\n");
    print (SRCHTML "<HTML>\n");
    print (SRCHTML "<HEAD>\n");
    print (SRCHTML "<LINK rel=\"stylesheet\" href=\"src_style.css\" type=\"text/css\" >\n");
    print (SRCHTML "<TITLE>Cluster OpenMP SEGVprof Information for $src</TITLE>\n");
    print (SRCHTML "</HEAD>\n");
    print (SRCHTML "<BODY>\n");
    print (SRCHTML "<DIV ID=\"wrap\">\n");
    print (SRCHTML "<DIV ID=\"header\">\n");
    print (SRCHTML "<H1 class=\"fixed\">$src</H1>\n");
    print (SRCHTML "</DIV>\n");
    print (SRCHTML "<DIV ID=\"content-wrap\">\n");
    print (SRCHTML "<DIV ID=\"content\">\n");
    print (SRCHTML "<PRE>\n");
    my $ln = 0;
    while (my $getline = <SRC>){
	++$ln;
	encode_entities($getline);
	if (exists $line_colors{$ln}){
#	my $tmp = "<span style=\"color: #D3D3D3\">%4d)</span>"
	    printf  (SRCHTML "<span style=\"color: #D3D3D3\">%4d)</span>"
		."<span style=\"background-color:$line_colors{$ln}{'Total'}\"> T </span>"
		."<span style=\"background-color:$line_colors{$ln}{'Write SEGVs'}\"> W </span>"
		."<span style=\"background-color:$line_colors{$ln}{'Wait SEGVs'}\"> I </span>"
		."<span style=\"background-color:$line_colors{$ln}{'Fetch SEGVs'}\"> F </span>"
		."<a name=\"l%d\" style = \"background-color:lightblue\">%s</a>", $ln, $ln,  $getline); 
	}else{	
	    printf  (SRCHTML "<span style=\"color: #D3D3D3\">%4d)</span>"
		."&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;"
		."<a name=\"l%d\">%s</a>", $ln, $ln,  $getline); 
	}	
    }
    print (SRCHTML "</PRE>\n");
    print (SRCHTML "</DIV>\n");
    print (SRCHTML "</DIV>\n");
    print (SRCHTML "<DIV ID=\"footer\">\n");

    # Create Legend table in the footer
    print (SRCHTML "<TABLE class=legend ALIGN=\"center\" BORDER=\"thin solid #000\" CELLSPACING=\"1\" CELLPADDING=\"1\" >\n");
    print (SRCHTML "<TR>\n");
    print (SRCHTML "<TH>Color</TH>\n");
    print (SRCHTML "<TH>Meaning</TH>\n");
    print (SRCHTML "<TH>Color</TH>\n");
    print (SRCHTML "<TH>Meaning</TH>\n");
    print (SRCHTML "<TH>Color</TH>\n");
    print (SRCHTML "<TH>Meaning</TH>\n");
    print (SRCHTML "</TR>\n");
    print (SRCHTML "<TR>\n");
    print (SRCHTML "<TD BGCOLOR=\"red\">&nbsp;</TD>\n");
    print (SRCHTML "<TD BGCOLOR=\"white\">80-100% of segv in a range</TD>\n");
    print (SRCHTML "<TD BGCOLOR=\"pink\">&nbsp;</TD>\n");
    print (SRCHTML "<TD BGCOLOR=\"white\">60-80% of segv in a range</TD>\n");
    print (SRCHTML "<TD BGCOLOR=\"orange\">&nbsp;</TD>\n");
    print (SRCHTML "<TD BGCOLOR=\"white\">40-60% of segv in a range</TD>\n");
    print (SRCHTML "</TR>\n");
    print (SRCHTML "<TR>\n");
    print (SRCHTML "<TD BGCOLOR=\"yellow\">&nbsp;</TD>\n");
    print (SRCHTML "<TD BGCOLOR=\"white\">20-40% of segv in a range</TD>\n");
    print (SRCHTML "<TD BGCOLOR=\"white\">&nbsp;</TD>\n");
    print (SRCHTML "<TD BGCOLOR=\"white\">0-20% of segv in a range</TD>\n");
    print (SRCHTML "<TD COLSPAN=2 BGCOLOR=\"white\">&nbsp;</TD>\n");
    print (SRCHTML "</TR>\n");
    print (SRCHTML "<TR>\n");
    print (SRCHTML "<TD COLSPAN=6 BGCOLOR=\"white\"><B>SEGV type: T=Total, W=Write, I=Wait, F=Fetch</B></TD>\n");
    print (SRCHTML "</TR>\n");
    print (SRCHTML "</TABLE>\n");

    print (SRCHTML "</DIV>\n");
    print (SRCHTML "</DIV>\n");
    print (SRCHTML "</BODY>\n");
    print (SRCHTML "</HTML>\n");
    
    close (SRC) or die ("Cannot close file: $!\n");
    close (SRCHTML) or die ("Cannot close file: $!\n");
    close (SUM) or die ("Cannot close file: $!\n");

    print (SRCFRM "<FRAME NAME=\"src_view\" SRC=\"$file\_src.html\" SCROLLING=\"yes\">\n"); 
    print (SRCFRM "<NOFRAMES> Your browser does not have frames support</NOFRAMES>\n");
    print (SRCFRM "</FRAMESET>\n");
    print (SRCFRM "</HTML>\n");	

    close (SRCFRM) or die ("Cannot close file: $!\n");
}

# Check if --pc specified
if ($by_lines)# --pc NOT specified; print_accumulated used
{
    # %accumulated hash creaton moved above!

    # Create an array containing all statistic names collected in all regions	
    my @segvs = create_stat_array ($by_lines, %accumulated);

    # Create Region Table HEAD using statistic names array found above
    print (HTML "<TABLE class = \"sortable\" BORDER=\"1\" CELLSPACING=\"1\" CELLPADDING=\"4\" ALIGN=\"center\">\n");
    print (HTML "<THEAD>\n");
    print (HTML "<TR ID=grey>\n");
    print (HTML "<TH>Region</TH>\n");
    foreach my $entry (@segvs){
        print (HTML "<TH>$entry</TH>\n");
    }
    print (HTML "</TR>\n");
    print (HTML "</THEAD>\n");
    print (HTML "<TBODY>\n");
        
    foreach my $region (sort by_region_name keys %accumulated){
	my $tmp_region=$region;
	$tmp_region =~ s/ /_/g;
	$tmp_region =~ s/#//g;
	print ($region, "\n");
	my $stat;

	# Create Region Table BODY
	print (HTML "<TR>\n");
	print (HTML "<TD class=L>$region</TD>\n");
	my $num = 0; # Will count number of statistics
	foreach $stat (sort by_statistic keys %{$accumulated{$region}}){
            $num++;
	    my $tmp_stat=$stat;
	    $tmp_stat =~ s/ /_/g;

	    # Create Region: SEGV  html file
	    open (REG, ">$main_html/$tmp_region\_$tmp_stat.html") or die ("Cannot open region file: $!\n");
	    print (REG "<HTML>\n");
	    print (REG "<HEAD>\n");
	    print (REG "<SCRIPT SRC=\"sort_table.js\" TYPE=\"text/javascript\"></SCRIPT>\n");
	    print (REG "<LINK rel=\"stylesheet\" href=\"src_style.css\" type=\"text/css\" >\n");
	    print (REG "<META http-equiv=\"Content-type\" content=\"text/html; charset =utf-8\"/>\n");
            print (REG "<TITLE>Cluster OpenMP SEGVprof for $region: $stat</TITLE>\n");
	    print (REG "</HEAD>\n");
	    print (REG "<BODY>\n");
	    print (REG "<H1>$region: $stat</H1>\n");
#	    print (REG "<H1 ALIGN=\"center\" STYLE=\"font-family:Arial,Helvetica;color:#3366ff\">$region: $stat</H1>\n");

	    my $grandtotal = print_accumulated ($stat, $accumulated{$region}->{$stat});
	    # Print all SEGV Grand Total values for this region to the table  
	    print (HTML "<TD class=C><a href=\"$main_html/$tmp_region\_$tmp_stat.html\">$grandtotal</a></TD>\n");
	    
	    print (REG "</BODY>\n");
	    print (REG "</HTML>\n");
	    close (REG) or die ("Cannot close file: $!\n");
	}
	# Draw empty cells for zero segvs
	for (my $i = $num; $i <= $#segvs; $i++){
	    print (HTML "<TD class=\"C empty\">0</TD>\n");
	}
	print (HTML "</TR>\n");
    }
    print (HTML "</TBODY>\n");
    print (HTML "</TABLE>\n");
}
else # --pc specified; print_type used
{
    # Create an array containing all statistic names collected in all regions	
    my @segvs = create_stat_array ($by_lines) ;

    # Create Region Table HEAD using statistic names array found above
    print (HTML "<TABLE class =\"sortable\" BORDER=\"1\" CELLSPACING=\"1\" CELLPADDING=\"4\" ALIGN=\"center\">\n");
    print (HTML "<THEAD>\n");
    print (HTML "<TR ID=grey>\n");
    print (HTML "<TH>Region</TH>\n");
    foreach my $entry (@segvs){
        print (HTML "<TH>$entry</TH>\n");
    }
    print (HTML "</TR>\n");
    print (HTML "</THEAD>\n");
    print (HTML "<TBODY>\n");

    foreach my $region (sort by_region_name keys %statistics){
	my $tmp_region=$region;
	$tmp_region =~ s/ /_/g;
	$tmp_region =~ s/\#//g;
	print ($region, "\n");
	my $stat;

	# Create Region Table BODY 
	print (HTML "<TR>\n");
	print (HTML "<TD class=L>$region</TD>\n");

	my $num = 0; # Will count number of statistics
	foreach $stat (sort by_statistic keys %{$statistics{$region}}){
            $num++;
            my $tmp_stat=$stat;
	    $tmp_stat =~ s/ /_/g;
	    
	    # Create Region: SEGV html file 
	    open (REG, ">$main_html/$tmp_region\_$tmp_stat.html") or die ("Cannot open region file: $!\n");
	    print (REG "<HTML>\n");
	    print (REG "<HEAD>\n");
	    print (REG "<SCRIPT SRC=\"sort_table.js\" TYPE=\"text/javascript\"></SCRIPT>\n");
	    print (REG "<LINK rel=\"stylesheet\" href=\"src_style.css\" type=\"text/css\" >\n");
	    print (REG "<META http-equiv=\"Content-type\" content=\"text/html; charset =utf-8\"/>\n");
            print (REG "<TITLE>Cluster OpenMP SEGVprof for $region: $stat</TITLE>\n");
	    print (REG "</HEAD>\n");
	    print (REG "<BODY>\n");
	    print (REG "<H1>$region: $stat</H1>\n");
#	    print (REG "<H1 ALIGN=\"center\" STYLE=\"font-family:Arial,Helvetica;color:#3366ff\">$region: $stat</H1>\n");

	    my $grandtotal = print_type($stat, $statistics{$region}->{$stat});
	    # Print all SEGV Grand Total values for this region to the table  
	    print (HTML "<TD class=C><a href=\"$main_html/$tmp_region\_$tmp_stat.html\">$grandtotal</a></TD>\n");
	    
	    print (REG "</BODY>\n");
	    print (REG "</HTML>\n");
	    close (REG) or die ("Cannot close file: $!\n");
	}
	# Draw empty cells for zero segvs
	for (my $i = $num; $i <= $#segvs; $i++){
	    print (HTML "<TD class=\"C empty\">0</TD>\n");
	}
	print (HTML "</TR>\n");
    }
    print (HTML "</TBODY>\n");
    print (HTML "</TABLE>\n");
}
print (HTML "</BODY>\n");
print (HTML "</HTML>\n");
close (HTML) or die ("Cannot close file: $!\n");

print ("\n*****  Open ./$main_html.html file to view more detailed results *****\n\n");

exit( 0 );

__END__

--- src_style.css ---
/* Source page header and footer that are not scrolled */
html,body {margin:0;padding:0;height:100%;}
html>body #wrap {height:100%;}
#header {width:100%;height:4em;}
html>body #header {position:fixed;}
html>body #content-wrap {max-height:100%;}
html>body #content {padding:4em 1em 5em 1em;}
#footer {width:100%;height:5em;}
html>body #footer {position:fixed;bottom:0;}
html,body {color:#000;}
h1.fixed{margin:0.5em 0;font-family:Arial,Helvetica;font-size:x-large;text-align:center;color:#3366ff;}
#header,#footer {color:#3366ff;background-color:#e6e6e6;text-align:center;}
#content-wrap,#content {background:#fff}
/* Headers */
h1{margin-top:0.5em;text-align:center;font-family:Arial,Helvetica;color:#3366ff;}
h4 {margin-top:1em;margin-left:0.5em;text-align:left;font-family:Arial,Helvetica;color:#3366ff;}
/* All tables */
th{text-align:center;}
td.L{text-align:left;}
td.R{text-align:right;}
td.C{text-align:center;}
.empty{color:white;}
/* Table header */
#grey{background-color:#f0f0f0;}
/* Table font style */
table{font-family:Arial,Helvetica;font-size:x-small;}
/* Legend */
table.legend th{text-align:center;background-color:#f0f0f0;}
table.legend{font-family:Arial,Helvetica;font-size:xx-small;margin-top:1em;}
/* Summary table */
table.sum{position:relative;left:0.5em;top:-1em;}

--- sort_table.js ---
addEvent(window, "load", sortables_init);
var SORT_COLUMN_INDEX;
function addEvent(elm, evType, fn, useCapture)
{
  if (elm.addEventListener) {elm.addEventListener(evType, fn, useCapture); return true;} 
  else if (elm.attachEvent) {var r = elm.attachEvent("on"+evType, fn); return r; }
  else {alert("Handler could not be removed"); }
} 
function sortables_init() {
    if (!document.getElementsByTagName) return;
    tbls = document.getElementsByTagName("table"); 
    for (ti=0;ti<tbls.length;ti++) {
        thisTbl = tbls[ti];
        if (((' '+thisTbl.className+' ').indexOf("sortable") != -1)) ts_makeSortable(thisTbl); }
}
function ts_makeSortable(table) {
    if (table.rows && table.rows.length > 0) {var firstRow = table.rows[0];}
    if (!firstRow) return;
    for (var i=0;i<firstRow.cells.length;i++) {
        var cell = firstRow.cells[i];
        var txt = ts_getInnerText(cell); 
        cell.innerHTML = '<a href="#" class="sortheader" onclick="ts_resortTable(this);return false;">'+txt+'<span class="sortarrow"></span></a>';}
}
function getParent(el, pTagName) {
	if (el == null) return null;
	else if (el.nodeType == 1 && el.tagName.toLowerCase() == pTagName.toLowerCase()) return el;
	else return getParent(el.parentNode, pTagName);
}
function ts_getInnerText(el) {
	if (typeof el == "string") return el;
	if (typeof el == "undefined") return el; 
	if (el.innerText) return el.innerText;
	var str = "";
	var cs = el.childNodes;
	for (var i = 0; i < cs.length; i++) {
		switch (cs[i].nodeType) {
			case 1: str += ts_getInnerText(cs[i]); break; /* ELEMENT_NODE */
			case 3:	str += cs[i].nodeValue; break; /* TEXT_NODE */ }}
 	return str;
}
function ts_resortTable(lnk) {
    var span;
    for (var ci=0;ci<lnk.childNodes.length;ci++) {
        if (lnk.childNodes[ci].tagName && lnk.childNodes[ci].tagName.toLowerCase()=='span') span=lnk.childNodes[ci];  }
    var spantext = ts_getInnerText(span);
    var td = lnk.parentNode;
    var column = td.cellIndex;
    var table = getParent(td,'TABLE');
    if (table.rows.length <= 1) return;
    var itm = ts_getInnerText(table.rows[1].cells[column]);
    sortfn = ts_sort_caseinsensitive;
    if (itm.match(/^[\d\.]+$/)) sortfn = ts_sort_numeric;
    if (itm.match(/^[xX0-9a-fA-F]+$/)) sortfn = ts_sort_hex;
    SORT_COLUMN_INDEX = column;
    var firstRow = new Array();
    var newRows = new Array();
    for (i=0;i<table.rows[0].length;i++) { firstRow[i] = table.rows[0][i]; }
    for (j=1;j<table.rows.length;j++) { 
    	if (!table.rows[j].className || (table.rows[j].className.indexOf('sortbottom') == -1))
    		newRows[j-1] = table.rows[j]; } 
    newRows.sort(sortfn);
    var browser=navigator.appName;
    if (span.getAttribute("sortdir") == 'down') {
	if (browser == "Microsoft Internet Explorer") ARROW = '&nbsp;&darr;';
	else ARROW =  '&nbsp;&#x25BE;';
	newRows.reverse();
        span.setAttribute('sortdir','up'); } 
    else {
	if (browser == "Microsoft Internet Explorer") ARROW = '&nbsp;&uarr;';
	else ARROW = '&nbsp;&#x25B4;';
	span.setAttribute('sortdir','down'); }
    for (i=0;i<newRows.length;i++) {table.tBodies[0].appendChild(newRows[i]);}
    var allspans = document.getElementsByTagName("span");
    for (var ci=0;ci<allspans.length;ci++) {
        if (allspans[ci].className == 'sortarrow') {
            if (getParent(allspans[ci],"table") == getParent(lnk,"table")) allspans[ci].innerHTML = ''; } }
    span.innerHTML = ARROW;
}
function ts_sort_numeric(a,b) { 
    aa = parseFloat(ts_getInnerText(a.cells[SORT_COLUMN_INDEX]));
    if (isNaN(aa)) aa = 0;
    bb = parseFloat(ts_getInnerText(b.cells[SORT_COLUMN_INDEX])); 
    if (isNaN(bb)) bb = 0;
    return aa-bb;
}
function ts_sort_hex(a,b) {
    aa = parseInt(ts_getInnerText(a.cells[SORT_COLUMN_INDEX]));
    if (isNaN(aa)) aa = 0;
    bb = parseInt(ts_getInnerText(b.cells[SORT_COLUMN_INDEX])); 
    if (isNaN(bb)) bb = 0;
    return aa-bb;
}
function ts_sort_caseinsensitive(a,b) {
    aa = ts_getInnerText(a.cells[SORT_COLUMN_INDEX]).toLowerCase();
    bb = ts_getInnerText(b.cells[SORT_COLUMN_INDEX]).toLowerCase();
    if (aa==bb) return 0;
    if (aa<bb) return -1;
    return 1;
}

--- end ---

#
# Embedded documentation.
#

=pod

=head1 NAME

B<segvprof.pl> -- Profile SEGVs in Cluster OpenMP code

=head1 SYNOPSIS

B<segvprof.pl>  I<options>... I<profile_files>...

=head1 OPTIONS

=over

=item B<--doc>

Print full help message and exit.

=item B<--executable=>I<file>

Name the executable which was run.

=item B<-->[B<no>]B<fullpath>

Print full source file path (default no).

=item B<--help>

Print short help message and exit.

=item B<-->[B<no>]B<pc>

Display per PC (rather than per line) statistics (default no).

=item B<-->[B<no>]B<procs>

Show per proc statistics (default no).

=item B<--threshold=>I<number>

Do not show stats less than number (default 50).

=item B<--usage>

Print very short usage message and exit.

=item B<--version>

Print version and exit.

=back

In all cases the argument can be truncated to the minimal unambiguous extent.


=head1 ARGUMENTS

=over

=item I<profile_files>

The lists of profile files to be processed. Often simply *.gmon.

=back

=head1 DESCRIPTION

B<segvprof.pl> is a tool for creating a profile of the segmentation faults
caused by the memory consistency protocol for sharable memory at each
line in the user's code.  This provides you with a simple and
intuitive way to see what parts of your code are taking the most time
due to Cluster OpenMP memory management.

=head2 Background

The Cluster OpenMP memory consistency protocol causes a segmentation
fault on a sharable page in three cases:

=over

=item 1.

FETCH fault: This type of fault occurs in two cases.

=over

=item a.	

At the first read to the page after it has been invalidated due to a
write notice from another process.  This causes the page to become
read-valid.

=item b.	

At the first write to the page after it has been invalidated due to a
write notice from another process.  This causes it to become
write-valid.  A write-valid page can become read-valid if its changes
are consumed by another process.

=back

Either of these cases will cause data to be fetched from another
process to bring the page up-to-date.  This is the most expensive type
of fault because it causes one or more message exchanges with other
processes.

=item 2.

WRITE fault: This type of fault occurs at the first write to the page
after it has been made read-valid. This is less expensive than a FETCH
fault because it does not cause data to be fetched from another
process.

=item 3.

WAIT fault: This type of fault occurs when the current thread in a
process faults while another thread in the same process is actively
satisfying a FETCH or a WRITE fault for the same page.  The current
thread will wait until the other thread has finished its request
before continuing.  This is also less expensive than a FETCH fault.

=back

=head2 How to Collect Statistics

=over

=item 1.

Compile your code with -g to enable debug information.  Failure to do
this step will give you a profile but you will not be able to get line
number information.  If you compile with -cluster-openmp-profile then
the statistics will be collected based on the same region information
as is collected in the guide.gvs file.

=item 2.

Set KMP_CLUSTER_PROFILE in your kmp_cluster.ini file, or the
environment. This can be set to anything to turn on profiling.

=item 3.

Run your application

=back

One .gmon file is created for each process used in the profiling run,
and is named <executable>_<processno>.gmon, for example "a.out_0" or
"erhs.exe_2".

=head2 How to run segvprof.pl

The segvprof.pl tool has a number of switches to control the way in which it summarizes the data. 

The simplest usage looks like this

    % segvprof.pl -e <exe>  *.gmon

This will generate output which aggregates the output across all of
the processes, but retains information about the precise program
counter value at which each SEGV fault occurred. That will look
something like this

    Region #6
    Total:
	 Count Function                     Source Location/Library
	   114 erhs                         erhs.f:348
	    66 erhs                         erhs.f:333
	     7 (3%) at 5 locations below the threshold of 50.
	   187 Grand Total

    Write SEGVs:
	 Count Function                     Source Location/Library
	    57 erhs                         erhs.f:348
	     2 (3%) at 2 locations below the threshold of 50.
	    59 Grand Total

    Fetch SEGVs:
	 Count Function                     Source Location/Library
	    66 erhs                         erhs.f:333
	    57 erhs                         erhs.f:348
	     5 (3%) at 4 locations below the threshold of 50.
	   128 Grand Total

=head2 Reading the Output

A sample of the output format is shown above.

The sections represent the following:

=over

=item Total:

A sum of the number of faults for the requested level of aggregation.

=item Fetch SEGVs:  

The total number of FETCH faults.  These faults require data to be
fetched from another process and therefore they are by far the most
expensive.

=item Write SEGVs: 

The total number of WRITE faults.  These faults cause a twin copy of a
page to be created but do not require any remote data.

=item Wait SEGVs: 

The total number of WAIT faults.  These faults cause the thread to
sleep and wait for the page to be updated by another thread.

=back

Concentrating on sharable data accesses that cause many FETCH faults
is a good place to start optimizing your code.

By using the -pc flag you can expand the detail to see each individual
faulting program counter within a single source line. This can be
useful to see how many different memory accesses within the line cause
faults, and, in conjunction with a debugger or dis-assembler you can
use the PC value to see the precise instruction causing the fault.

By using the -pr flag you can analyze the data and see which processes
are causing the problem. For instance you may see that all the
processes except process zero have many faults in a parallel region
which follows a serial region in which process zero updated sharable
data. Ideally you want to ensure that accesses and updates occur in
the same process as much as possible.

By using the -t <count> argument you can reduce the size of the output
file so that you can focus on the interesting parts. As you can see in
the sample output above the truncated data is still accumulated and
printed in the totals. In addition, the amount of data truncated is
displayed as a percentage of the total, so that you can see if you
have truncated too much.

If you are interested in the statistics from only some subset of the
processes, then feed only the .gmon files from those processes into
segvprof.pl.

=head2 Html-formatted Output

Segvprof.pl also provides html-interface for viewing result. The tool
generates a set of html-files containing more detailed results. To see the
results you should open the html-file located in the current working
directory. The name of this file is displayed in the output when the script
finishes and has format like SEGVprof_<executable-name>.html.

All other html-files generated during segvprof.pl run are put into a special
directory named SEGVprof_<executable-name>. Since the resulting html-files
have different names for different executables you can keep results for
several segvprof.pl runs. 

With this html-interface you will be able not just see the SEGV faults information grouped by regions as presented above
but also see source code colored according to frequency of each type of
SEGV faults. Red lines correspond to the top 20% of the count range of the
faults, whereas lines in the bottom 20% of the range don't have color. The
color intensity changes from red to white through pink, orange and yellow
for different levels.

=head1 EXAMPLES

=head1 SEE ALSO

=head1 AUTHOR

=cut

# end of file #