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