summaryrefslogtreecommitdiff
path: root/utils/prof/ghcprof.prl
diff options
context:
space:
mode:
Diffstat (limited to 'utils/prof/ghcprof.prl')
-rw-r--r--utils/prof/ghcprof.prl280
1 files changed, 280 insertions, 0 deletions
diff --git a/utils/prof/ghcprof.prl b/utils/prof/ghcprof.prl
new file mode 100644
index 0000000000..bc3b344228
--- /dev/null
+++ b/utils/prof/ghcprof.prl
@@ -0,0 +1,280 @@
+# -----------------------------------------------------------------------------
+# $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);
+}
View Lorry Controller Status