+++ /dev/null
-# -----------------------------------------------------------------------------
-# $Id: ghcprof.prl,v 1.5 2005/04/22 08:41:00 simonmar Exp $
-#
-# (c) The GHC Team 2000
-#
-# needs: DEFAULT_TMPDIR, TARGETPLATFORM, icondir, xmlparser, cgprof_dir
-#
-
-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;
-
-# 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);
-}
projects / ghc-hetmet.git / blobdiff