path: root/utils/prof/ghcprof.prl

# -----------------------------------------------------------------------------
# $Id: ghcprof.prl,v 1.5 2005/04/22 08:41:00 simonmar Exp $
#
# (c) The GHC Team 2000
#
# needs: FPTOOLS_TOP_ABS, INSTALLING, DEFAULT_TMPDIR, TARGETPLATFORM, libexecdir
#

if ($ENV{'UDG_HOME'}) {
    $udrawgraphhome = $ENV{'UDG_HOME'};
    $udrawgraph     = $udrawgraphhome . "/bin/uDrawGraph";
} else {
    print STDERR "ghcprof: UDG_HOME environment variable not set\n";
    exit(1);
}

$machname      = ${TARGETPLATFORM};
$bsp_s         = 10.0;
$bsp_l         = 12;
$bsp_g         = 13;
$MaxNoNodes    = 1900;

$icondir    = ( $INSTALLING ? "$libexecdir/icons" 
	                    : "$FPTOOLS_TOP_ABS/ghc/utils/prof/icons" );
 
$xmlparser  = ( $INSTALLING ? "$libexecdir/xmlparser"
	                    : "$FPTOOLS_TOP_ABS/ghc/utils/prof/xmlparser/xmlparser" );

$cgprof_dir = ( $INSTALLING ? "$libexecdir"
	                    : "$FPTOOLS_TOP_ABS/ghc/utils/prof/cgprof" );

# where to make tmp file names?
if ( $ENV{'TMPDIR'} ) {
    $Tmp_prefix = $ENV{'TMPDIR'} . "/ghcprof";
} else {
    $Tmp_prefix ="${DEFAULT_TMPDIR}/ghcprof";
    $ENV{'TMPDIR'} = "${DEFAULT_TMPDIR}"; # set the env var as well
}

# Create a new temporary filename.
$i = $$;
$tempfile = "";
while (-e ($tempfile = "$Tmp_prefix" . "$i")) {
    $i++;
};

# Create a second temporary filename.
$i = $$;
$tempfile2 = "";
while (-e ($tempfile2 = "$Tmp_prefix" . "$i" . ".sh")) {
    $i++;
};

# Delete temp. file if script is halted.
sub quit_upon_signal { 
    if ($tempfile ne "" && -e $tempfile) {
	print STDERR "Deleting $tempfile .. \n" if $Verbose; 
	unlink "$tempfile"; 
    };
    if ($tempfile2 ne "" && -e $tempfile2) {
	print STDERR "Deleting $tempfile2 .. \n" if $Verbose; 
	unlink "$tempfile2"; 
    }
}

$SIG{'INT'}  = 'quit_upon_signal';
$SIG{'QUIT'} = 'quit_upon_signal';

sub tidy_up_and_die { 
    local($msg) = @_;
    
    print STDERR "$Pgm: $msg\n";
    quit_upon_signal;
    exit(1);
}

select(STDERR); $| = 1; select(STDOUT); # no STDERR buffering, please.
($Pgm = $0) =~ s|.*/||;
$Version        = "v2.1 10-3-2000";
$bug_reports_to = 'stephen.jarvis@dcs.warwick.ac.uk';

$ShortUsage = "\n$Pgm usage: for basic information, try the `-help' option\n";

$Usage = <<EOF
Usage: $Pgm [option...] filename.prof

Options:
    -v          Verbose
    -hide       (???)
    -nologo     Omit the logo
    -grey       Greyscale only
    -color      Enable color (default)
    -normalise  (???)
EOF
    ;

$Verbose       = 0;
$InputFile     = "";
$date          = "";
$nprocs        = 0;
$hide          = 0.01;
$Logo          = 1;
$Colour        = 1;
$DeltaNormalise= 2;

 arg: while ($_ = $ARGV[0]) {
     shift(@ARGV);
     #--------HELP------------------------------------------------
     /^-help$/   && do { print STDERR $Usage; exit(0); };
     
     /^-v$/      && do {$Verbose = 1; next arg;};
     
     /^-hide$/   && do {$hide= &grab_next_arg("-hide");
			if (($hide =~ /^(\d+.\d+)$/) || ($hide =~ /^(\d+)$/)) {
			    $hide = $1/100.0;
			} else {
			    print STDERR "$Pgm: -hide requires a percentage as ",
			    "an argument\n";
			    $Status++;
			}
			next arg;};
     
     /^-nologo$/    && do {$Logo  =0; next arg;};
     /^-gr(e|a)y$/  && do {$Colour=0; next arg;};
     /^-colou?r$/   && do {$Colour=1; next arg;};
     /^-normalise$/ && do {$DeltaNormalise = &grab_next_arg("-normalise");
			   if ($DeltaNormalise =~ /^(\d+)$/) {
			       $DeltaNormalise = int($DeltaNormalise);
			   } else {
			       print STDERR "$Pgm: -normalise requires an integer ",
			       "an argument\n";
			       $Status++;
			   }
			   next arg;};
     
     /^-/           && do { print STDERR "$Pgm: unrecognised option \"",$_,"\"\n"; 
			    $Status++;
			};
     
     if ($InputFile eq "") {
	 $InputFile = $_; next arg; 
     } else {
	 $Status++;
     };
 }

if ($InputFile eq "") {
    print STDERR "$Pgm: no input file given\n";
    $Status++;
}  
if ($Status>0) {
    print STDERR $ShortUsage;
    exit(1);
}
print STDERR "$Pgm: ($Version)\n" if $Verbose;

# -----------------------------------------------------------------------------
# Parse the XML

# ToDo: use the real xmlparser
# system("$xmlparser < $InputFile > $tempfile");
# if ($? != 0) { tidy_up_and_die("xmlparser failed"); }

# Stehpen's hacky replacement for xmlparser:

$cc_write  = 1; 
$ccs_write = 1;
$scc_write = 1;

open(INPUT, "<$InputFile") || tidy_up_and_die("can't open `$InputFile'");
open(TEMPFILE, ">$tempfile") || tidy_up_and_die("can't create `$tempfile'");

while (<INPUT>) { 
    if (/^1 (\d+) (.*)$/)
    {
	if ($cc_write) { 
	    print TEMPFILE ">>cost_centre\n"; 
	    $cc_write = 0; 
	}
	$cc_id		= $1;
	$name		= $2;
	$module		= $3;
	print TEMPFILE "$cc_id $name $module\n"; 
    }	
    if (/^2 (\d+) (\d+) (\d+)$/)
    {
	if ($ccs_write) {
	    print TEMPFILE ">>cost_centre_stack\n";
	    $ccs_write = 0;
	}
	$ccs_id         = $1;
	$ccptr          = $2;
	$ccsptr         = $3;
	print TEMPFILE "$ccs_id $ccptr $ccsptr\n";
    } 
    elsif (/^2 (\d+) (\d+) (\d+) (\d+)$/)
    {
	if ($ccs_write) {
	    print TEMPFILE ">>cost_centre_stack\n";
	    $ccs_write = 0;
	}
	$ccs_id         = $1;
	$type           = $2;
	$ccptr          = $3;
	$ccsptr		= $4;
	print TEMPFILE "$ccs_id $type $ccptr $ccsptr\n";
    } 
    if (/^5 (\d+) (.*)$/)
    {
	if ($scc_write) {
	    print TEMPFILE ">>scc_sample\n";
	    $scc_write = 0;
	}
	$_		= $2;
	while (/^1 (\d+) (\d+) (\d+) (\d+) (.*)$/) 
	{
	    $rg1		= $1;
	    $rg2		= $2;
	    $rg3		= $3;
	    $rg4		= $4;
	    print TEMPFILE "$rg1 $rg2 $rg3 $rg4\n";
	    $_		= $5;
	}	
    }
}
print TEMPFILE ">>\n";

close(INPUT);
close(TEMPFILE);

&readProfileHeader();
open(TEMPFILE2, ">$tempfile2") 
                || tidy_up_and_die("can't create `$tempfile2'");

$shcmd = sprintf("%s/cgprof %s %d \"%s\" " .
	       "\"%s\" %.1f %.1f %.1f %.1f %d %d %d %d %d",
	       $cgprof_dir,$tempfile,$nprocs,$machname,$date,
	       $bsp_s,$bsp_l,$bsp_g,$hide,$Verbose,$Logo,$Colour,
	       $DeltaNormalise,$MaxNoNodes);
print TEMPFILE2 "#!/bin/sh\n";
print TEMPFILE2 "$shcmd\n";
close(TEMPFILE2);

chmod 0755, $tempfile2;
$cmd = "env UDG_ICONDIR=$icondir UDG_HOME=$udrawgraphhome " . 
         $udrawgraph . " -startappl . $tempfile2";
print STDERR "$Pgm: exec $cmd\n" if $Verbose;
exec $cmd;
exit(0);

sub readProfileHeader {
    local($found);
    
    open(PROFILE,$tempfile) || tidy_up_and_die("can't open `$tempfile'");
    $found=0;
    
    while(<PROFILE>) {
	if (/^F/) {
	    if (/-prof/ && /-flibrary-level\s+(\d+)/) {
		$libtype = "P$1";
	    } elsif (/-flibrary-level\s+(\d+)/) {
		$libtype = "O$1";
	    }
	    $found++;
	    
	} elsif (/^P\s*/) {
	    $nprocs = int($');
	    $found++;
	    
	} elsif (/^D\s*/) {
	    chop($date = $');
	    $found++;
	    
	} elsif (/^X\s*/) {
	    chop($device = $');
	}
	last if ($found>=3);
    }
    close(PROFILE);
}