utils/prof/ghcprof.prl

   1 # -----------------------------------------------------------------------------
   2 # $Id: ghcprof.prl,v 1.5 2005/04/22 08:41:00 simonmar Exp $
   3 #
   4 # (c) The GHC Team 2000
   5 #
   6 # needs: FPTOOLS_TOP_ABS, INSTALLING, DEFAULT_TMPDIR, TARGETPLATFORM, libexecdir
   7 #
   8
   9 if ($ENV{'UDG_HOME'}) {
  10     $udrawgraphhome = $ENV{'UDG_HOME'};
  11     $udrawgraph     = $udrawgraphhome . "/bin/uDrawGraph";
  12 } else {
  13     print STDERR "ghcprof: UDG_HOME environment variable not set\n";
  14     exit(1);
  15 }
  16
  17 $machname      = ${TARGETPLATFORM};
  18 $bsp_s         = 10.0;
  19 $bsp_l         = 12;
  20 $bsp_g         = 13;
  21 $MaxNoNodes    = 1900;
  22
  23 $icondir    = ( $INSTALLING ? "$libexecdir/icons"
  24                             : "$FPTOOLS_TOP_ABS/ghc/utils/prof/icons" );
  25
  26 $xmlparser  = ( $INSTALLING ? "$libexecdir/xmlparser"
  27                             : "$FPTOOLS_TOP_ABS/ghc/utils/prof/xmlparser/xmlparser" );
  28
  29 $cgprof_dir = ( $INSTALLING ? "$libexecdir"
  30                             : "$FPTOOLS_TOP_ABS/ghc/utils/prof/cgprof" );
  31
  32 # where to make tmp file names?
  33 if ( $ENV{'TMPDIR'} ) {
  34     $Tmp_prefix = $ENV{'TMPDIR'} . "/ghcprof";
  35 } else {
  36     $Tmp_prefix ="${DEFAULT_TMPDIR}/ghcprof";
  37     $ENV{'TMPDIR'} = "${DEFAULT_TMPDIR}"; # set the env var as well
  38 }
  39
  40 # Create a new temporary filename.
  41 $i = $$;
  42 $tempfile = "";
  43 while (-e ($tempfile = "$Tmp_prefix" . "$i")) {
  44     $i++;
  45 };
  46
  47 # Create a second temporary filename.
  48 $i = $$;
  49 $tempfile2 = "";
  50 while (-e ($tempfile2 = "$Tmp_prefix" . "$i" . ".sh")) {
  51     $i++;
  52 };
  53
  54 # Delete temp. file if script is halted.
  55 sub quit_upon_signal {
  56     if ($tempfile ne "" && -e $tempfile) {
  57         print STDERR "Deleting $tempfile .. \n" if $Verbose;
  58         unlink "$tempfile";
  59     };
  60     if ($tempfile2 ne "" && -e $tempfile2) {
  61         print STDERR "Deleting $tempfile2 .. \n" if $Verbose;
  62         unlink "$tempfile2";
  63     }
  64 }
  65
  66 $SIG{'INT'}  = 'quit_upon_signal';
  67 $SIG{'QUIT'} = 'quit_upon_signal';
  68
  69 sub tidy_up_and_die {
  70     local($msg) = @_;
  71
  72     print STDERR "$Pgm: $msg\n";
  73     quit_upon_signal;
  74     exit(1);
  75 }
  76
  77 select(STDERR); $| = 1; select(STDOUT); # no STDERR buffering, please.
  78 ($Pgm = $0) =~ s|.*/||;
  79 $Version        = "v2.1 10-3-2000";
  80 $bug_reports_to = 'stephen.jarvis@dcs.warwick.ac.uk';
  81
  82 $ShortUsage = "\n$Pgm usage: for basic information, try the `-help' option\n";
  83
  84 $Usage = <<EOF
  85 Usage: $Pgm [option...] filename.prof
  86
  87 Options:
  88     -v          Verbose
  89     -hide       (???)
  90     -nologo     Omit the logo
  91     -grey       Greyscale only
  92     -color      Enable color (default)
  93     -normalise  (???)
  94 EOF
  95     ;
  96
  97 $Verbose       = 0;
  98 $InputFile     = "";
  99 $date          = "";
 100 $nprocs        = 0;
 101 $hide          = 0.01;
 102 $Logo          = 1;
 103 $Colour        = 1;
 104 $DeltaNormalise= 2;
 105
 106  arg: while ($_ = $ARGV[0]) {
 107      shift(@ARGV);
 108      #--------HELP------------------------------------------------
 109      /^-help$/   && do { print STDERR $Usage; exit(0); };
 110
 111      /^-v$/      && do {$Verbose = 1; next arg;};
 112
 113      /^-hide$/   && do {$hide= &grab_next_arg("-hide");
 114                         if (($hide =~ /^(\d+.\d+)$/) || ($hide =~ /^(\d+)$/)) {
 115                             $hide = $1/100.0;
 116                         } else {
 117                             print STDERR "$Pgm: -hide requires a percentage as ",
 118                             "an argument\n";
 119                             $Status++;
 120                         }
 121                         next arg;};
 122
 123      /^-nologo$/    && do {$Logo  =0; next arg;};
 124      /^-gr(e|a)y$/  && do {$Colour=0; next arg;};
 125      /^-colou?r$/   && do {$Colour=1; next arg;};
 126      /^-normalise$/ && do {$DeltaNormalise = &grab_next_arg("-normalise");
 127                            if ($DeltaNormalise =~ /^(\d+)$/) {
 128                                $DeltaNormalise = int($DeltaNormalise);
 129                            } else {
 130                                print STDERR "$Pgm: -normalise requires an integer ",
 131                                "an argument\n";
 132                                $Status++;
 133                            }
 134                            next arg;};
 135
 136      /^-/           && do { print STDERR "$Pgm: unrecognised option \"",$_,"\"\n";
 137                             $Status++;
 138                         };
 139
 140      if ($InputFile eq "") {
 141          $InputFile = $_; next arg;
 142      } else {
 143          $Status++;
 144      };
 145  }
 146
 147 if ($InputFile eq "") {
 148     print STDERR "$Pgm: no input file given\n";
 149     $Status++;
 150 }
 151 if ($Status>0) {
 152     print STDERR $ShortUsage;
 153     exit(1);
 154 }
 155 print STDERR "$Pgm: ($Version)\n" if $Verbose;
 156
 157 # -----------------------------------------------------------------------------
 158 # Parse the XML
 159
 160 # ToDo: use the real xmlparser
 161 # system("$xmlparser < $InputFile > $tempfile");
 162 # if ($? != 0) { tidy_up_and_die("xmlparser failed"); }
 163
 164 # Stehpen's hacky replacement for xmlparser:
 165
 166 $cc_write  = 1;
 167 $ccs_write = 1;
 168 $scc_write = 1;
 169
 170 open(INPUT, "<$InputFile") || tidy_up_and_die("can't open `$InputFile'");
 171 open(TEMPFILE, ">$tempfile") || tidy_up_and_die("can't create `$tempfile'");
 172
 173 while (<INPUT>) {
 174     if (/^1 (\d+) (.*)$/)
 175     {
 176         if ($cc_write) {
 177             print TEMPFILE ">>cost_centre\n";
 178             $cc_write = 0;
 179         }
 180         $cc_id          = $1;
 181         $name           = $2;
 182         $module         = $3;
 183         print TEMPFILE "$cc_id $name $module\n";
 184     }
 185     if (/^2 (\d+) (\d+) (\d+)$/)
 186     {
 187         if ($ccs_write) {
 188             print TEMPFILE ">>cost_centre_stack\n";
 189             $ccs_write = 0;
 190         }
 191         $ccs_id         = $1;
 192         $ccptr          = $2;
 193         $ccsptr         = $3;
 194         print TEMPFILE "$ccs_id $ccptr $ccsptr\n";
 195     }
 196     elsif (/^2 (\d+) (\d+) (\d+) (\d+)$/)
 197     {
 198         if ($ccs_write) {
 199             print TEMPFILE ">>cost_centre_stack\n";
 200             $ccs_write = 0;
 201         }
 202         $ccs_id         = $1;
 203         $type           = $2;
 204         $ccptr          = $3;
 205         $ccsptr         = $4;
 206         print TEMPFILE "$ccs_id $type $ccptr $ccsptr\n";
 207     }
 208     if (/^5 (\d+) (.*)$/)
 209     {
 210         if ($scc_write) {
 211             print TEMPFILE ">>scc_sample\n";
 212             $scc_write = 0;
 213         }
 214         $_              = $2;
 215         while (/^1 (\d+) (\d+) (\d+) (\d+) (.*)$/)
 216         {
 217             $rg1                = $1;
 218             $rg2                = $2;
 219             $rg3                = $3;
 220             $rg4                = $4;
 221             print TEMPFILE "$rg1 $rg2 $rg3 $rg4\n";
 222             $_          = $5;
 223         }
 224     }
 225 }
 226 print TEMPFILE ">>\n";
 227
 228 close(INPUT);
 229 close(TEMPFILE);
 230
 231 &readProfileHeader();
 232 open(TEMPFILE2, ">$tempfile2")
 233                 || tidy_up_and_die("can't create `$tempfile2'");
 234
 235 $shcmd = sprintf("%s/cgprof %s %d \"%s\" " .
 236                "\"%s\" %.1f %.1f %.1f %.1f %d %d %d %d %d",
 237                $cgprof_dir,$tempfile,$nprocs,$machname,$date,
 238                $bsp_s,$bsp_l,$bsp_g,$hide,$Verbose,$Logo,$Colour,
 239                $DeltaNormalise,$MaxNoNodes);
 240 print TEMPFILE2 "#!/bin/sh\n";
 241 print TEMPFILE2 "$shcmd\n";
 242 close(TEMPFILE2);
 243
 244 chmod 0755, $tempfile2;
 245 $cmd = "env UDG_ICONDIR=$icondir UDG_HOME=$udrawgraphhome " .
 246          $udrawgraph . " -startappl . $tempfile2";
 247 print STDERR "$Pgm: exec $cmd\n" if $Verbose;
 248 exec $cmd;
 249 exit(0);
 250
 251 sub readProfileHeader {
 252     local($found);
 253
 254     open(PROFILE,$tempfile) || tidy_up_and_die("can't open `$tempfile'");
 255     $found=0;
 256
 257     while(<PROFILE>) {
 258         if (/^F/) {
 259             if (/-prof/ && /-flibrary-level\s+(\d+)/) {
 260                 $libtype = "P$1";
 261             } elsif (/-flibrary-level\s+(\d+)/) {
 262                 $libtype = "O$1";
 263             }
 264             $found++;
 265
 266         } elsif (/^P\s*/) {
 267             $nprocs = int($');
 268             $found++;
 269
 270         } elsif (/^D\s*/) {
 271             chop($date = $');
 272             $found++;
 273
 274         } elsif (/^X\s*/) {
 275             chop($device = $');
 276         }
 277         last if ($found>=3);
 278     }
 279     close(PROFILE);
 280 }