1 # -----------------------------------------------------------------------------
2 # $Id: ghcprof.prl,v 1.1 2000/04/05 10:06:36 simonmar Exp $
4 # (c) The GHC Team 2000
6 # needs: INSTALLING, FPTOOLS_TOP_ABS, libdir, TARGETPLATFORM, TMPDIR
9 if ($ENV{'DAVINCIHOME'}) {
10 $davincihome = $ENV{'DAVINCIHOME'};
11 $davinci = $davincihome . "/daVinci";
13 print STDERR "ghcprof: DAVINCIHOME environment variable not set";
17 $machname = ${TARGETPLATFORM};
23 $icondir = ( $INSTALLING ? "$libdir/icons"
24 : "$FPTOOLS_TOP_ABS/ghc/utils/prof/icons" );
26 $xmlparser = ( $INSTALLING ? "$libexecdir/xmlparser"
27 : "$FPTOOLS_TOP_ABS/ghc/utils/prof/xmlparser/xmlparser" );
29 $cgprof_dir = ( $INSTALLING ? "$libexecdir"
30 : "$FPTOOLS_TOP_ABS/ghc/utils/prof/cgprof" );
32 # where to make tmp file names?
33 if ( $ENV{'TMPDIR'} ) {
34 $Tmp_prefix = $ENV{'TMPDIR'} . "/ghcprof";
36 $Tmp_prefix ="${TMPDIR}/ghcprof";
37 $ENV{'TMPDIR'} = "${TMPDIR}"; # set the env var as well
40 # Create an new temporary filename.
43 while (-e ($tempfile = "$Tmp_prefix" . "$i")) {
47 # Delete temp. file if script is halted.
48 sub quit_upon_signal {
49 if ($tempfile ne "") {
50 print STDERR "Deleting $tempfile .. \n";
54 $SIG{'INT'} = 'quit_upon_signal';
55 $SIG{'QUIT'} = 'quit_upon_signal';
58 if ($tempfile ne "") {
59 print STDERR "Deleting $tempfile .. \n";
65 select(STDERR); $| = 1; select(STDOUT); # no STDERR buffering, please.
66 ($Pgm = $0) =~ s|.*/||;
67 $Version = "v2.1 10-3-2000";
68 $bug_reports_to = 'stephen.jarvis@dcs.warwick.ac.uk';
70 $ShortUsage = "\n$Pgm usage: for basic information, try the `-help' option\n";
73 Usage: $Pgm [option...] filename.prof
80 -color Enable color (default)
94 arg: while ($_ = $ARGV[0]) {
96 #--------HELP------------------------------------------------
97 /^-help$/ && do { print STDERR $Usage; exit(0); };
99 /^-v$/ && do {$Verbose = 1; next arg;};
101 /^-hide$/ && do {$hide= &grab_next_arg("-hide");
102 if (($hide =~ /^(\d+.\d+)$/) || ($hide =~ /^(\d+)$/)) {
105 print STDERR "$Pgm: -hide requires a percentage as ",
111 /^-nologo$/ && do {$Logo =0; next arg;};
112 /^-gr(e|a)y$/ && do {$Colour=0; next arg;};
113 /^-colou?r$/ && do {$Colour=1; next arg;};
114 /^-normalise$/ && do {$DeltaNormalise = &grab_next_arg("-normalise");
115 if ($DeltaNormalise =~ /^(\d+)$/) {
116 $DeltaNormalise = int($DeltaNormalise);
118 print STDERR "$Pgm: -normalise requires an integer ",
124 /^-/ && do { print STDERR "$Pgm: unrecognised option \"",$_,"\"\n";
128 if ($InputFile eq "") {
129 $InputFile = $_; next arg;
135 if ($InputFile eq "") {
136 print STDERR "$Pgm: no input file given\n";
140 print STDERR $ShortUsage;
143 print STDERR "$Pgm: ($Version)\n" if $Verbose;
145 # -----------------------------------------------------------------------------
148 # ToDo: use the real xmlparser
149 # system("$xmlparser < $InputFile > $tempfile");
150 # if ($? != 0) { tidy_up_and_die(); }
152 # Stehpen's hacky replacement for xmlparser:
158 open(INPUT, "<$InputFile") || tidy_up_and_die();
159 open(TEMPFILE, ">$tempfile") || tidy_up_and_die();
162 if (/^1 (\d+) (.*)$/)
165 print TEMPFILE ">>cost_centre\n";
171 print TEMPFILE "$cc_id $name $module\n";
173 if (/^2 (\d+) (\d+) (\d+)$/)
176 print TEMPFILE ">>cost_centre_stack\n";
182 print TEMPFILE "$ccs_id $ccptr $ccsptr\n";
184 elsif (/^2 (\d+) (\d+) (\d+) (\d+)$/)
187 print TEMPFILE ">>cost_centre_stack\n";
194 print TEMPFILE "$ccs_id $type $ccptr $ccsptr\n";
196 if (/^5 (\d+) (.*)$/)
199 print TEMPFILE ">>scc_sample\n";
203 while (/^1 (\d+) (\d+) (\d+) (\d+) (.*)$/)
209 print TEMPFILE "$rg1 $rg2 $rg3 $rg4\n";
214 print TEMPFILE ">>\n";
219 &readProfileHeader();
220 $cmd = sprintf("%s -startappl %s 'cgprof %s %d \"%s\" ".
221 "\"%s\" %.1f %.1f %.1f %.1f %d %d %d %d %d'",
222 $davinci,$cgprof_dir,$tempfile,$nprocs,$machname,$date,
223 $bsp_s,$bsp_l,$bsp_g,$hide,$Verbose,$Logo,$Colour,
224 $DeltaNormalise,$MaxNoNodes);
225 $cmd = "env DAVINCI_ICONDIR=$icondir TCL_LIBRARY=$davincihome/lib/tcl ".
226 "TK_LIBRARY=$davincihome/lib/tk DAVINCIHOME=$davincihome " . $cmd;
227 print STDERR "$Pgm: exec $cmd\n" if $Verbose;
231 sub readProfileHeader {
234 if (!open(PROFILE,$tempfile)) {
235 printf STDERR "$Pgm: unable to open profile file \"$tempfile\".\n";
236 $? = 1; tidy_up_and_die();
242 if (/-prof/ && /-flibrary-level\s+(\d+)/) {
244 } elsif (/-flibrary-level\s+(\d+)/) {