ghc/utils/prof/ghcprof.prl

   1 # -----------------------------------------------------------------------------
   2 # $Id: ghcprof.prl,v 1.1 2000/04/05 10:06:36 simonmar Exp $
   3 #
   4 # (c) The GHC Team 2000
   5 #
   6 # needs: INSTALLING, FPTOOLS_TOP_ABS, libdir, TARGETPLATFORM, TMPDIR
   7 #
   8
   9 if ($ENV{'DAVINCIHOME'}) {
  10     $davincihome = $ENV{'DAVINCIHOME'};
  11     $davinci     = $davincihome . "/daVinci";
  12 } else {
  13     print STDERR "ghcprof: DAVINCIHOME environment variable not set";
  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 ? "$libdir/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 ="${TMPDIR}/ghcprof";
  37     $ENV{'TMPDIR'} = "${TMPDIR}"; # set the env var as well
  38 }
  39
  40 # Create an new temporary filename.
  41 $i = $$;
  42 $tempfile = "";
  43 while (-e ($tempfile = "$Tmp_prefix" . "$i")) {
  44     $i++;
  45 };
  46
  47 # Delete temp. file if script is halted.
  48 sub quit_upon_signal {
  49     if ($tempfile ne "") {
  50         print STDERR "Deleting $tempfile .. \n";
  51         unlink "$tempfile";
  52     }
  53 }
  54 $SIG{'INT'}  = 'quit_upon_signal';
  55 $SIG{'QUIT'} = 'quit_upon_signal';
  56
  57 sub tidy_up_and_die {
  58     if ($tempfile ne "") {
  59         print STDERR "Deleting $tempfile .. \n";
  60         unlink "$tempfile";
  61     }
  62     exit($?);
  63 }
  64
  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';
  69
  70 $ShortUsage = "\n$Pgm usage: for basic information, try the `-help' option\n";
  71
  72 $Usage = <<EOF
  73 Usage: $Pgm [option...] filename.prof
  74
  75 Options:
  76     -v          Verbose
  77     -hide       (???)
  78     -nologo     Omit the logo
  79     -grey       Greyscale only
  80     -color      Enable color (default)
  81     -normalise  (???)
  82 EOF
  83     ;
  84
  85 $Verbose       = 0;
  86 $InputFile     = "";
  87 $date          = "";
  88 $nprocs        = 0;
  89 $hide          = 0.01;
  90 $Logo          = 1;
  91 $Colour        = 1;
  92 $DeltaNormalise= 2;
  93
  94  arg: while ($_ = $ARGV[0]) {
  95      shift(@ARGV);
  96      #--------HELP------------------------------------------------
  97      /^-help$/   && do { print STDERR $Usage; exit(0); };
  98
  99      /^-v$/      && do {$Verbose = 1; next arg;};
 100
 101      /^-hide$/   && do {$hide= &grab_next_arg("-hide");
 102                         if (($hide =~ /^(\d+.\d+)$/) || ($hide =~ /^(\d+)$/)) {
 103                             $hide = $1/100.0;
 104                         } else {
 105                             print STDERR "$Pgm: -hide requires a percentage as ",
 106                             "an argument\n";
 107                             $Status++;
 108                         }
 109                         next arg;};
 110
 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);
 117                            } else {
 118                                print STDERR "$Pgm: -normalise requires an integer ",
 119                                "an argument\n";
 120                                $Status++;
 121                            }
 122                            next arg;};
 123
 124      /^-/           && do { print STDERR "$Pgm: unrecognised option \"",$_,"\"\n";
 125                             $Status++;
 126                         };
 127
 128      if ($InputFile eq "") {
 129          $InputFile = $_; next arg;
 130      } else {
 131          $Status++;
 132      };
 133  }
 134
 135 if ($InputFile eq "") {
 136     print STDERR "$Pgm: no input file given\n";
 137     $Status++;
 138 }
 139 if ($Status>0) {
 140     print STDERR $ShortUsage;
 141     exit(1);
 142 }
 143 print STDERR "$Pgm: ($Version)\n" if $Verbose;
 144
 145 # -----------------------------------------------------------------------------
 146 # Parse the XML
 147
 148 # ToDo: use the real xmlparser
 149 # system("$xmlparser < $InputFile > $tempfile");
 150 # if ($? != 0) { tidy_up_and_die(); }
 151
 152 # Stehpen's hacky replacement for xmlparser:
 153
 154 $cc_write  = 1;
 155 $ccs_write = 1;
 156 $scc_write = 1;
 157
 158 open(INPUT, "<$InputFile") || tidy_up_and_die();
 159 open(TEMPFILE, ">$tempfile") || tidy_up_and_die();
 160
 161 while (<INPUT>) {
 162     if (/^1 (\d+) (.*)$/)
 163     {
 164         if ($cc_write) {
 165             print TEMPFILE ">>cost_centre\n";
 166             $cc_write = 0;
 167         }
 168         $cc_id          = $1;
 169         $name           = $2;
 170         $module         = $3;
 171         print TEMPFILE "$cc_id $name $module\n";
 172     }
 173     if (/^2 (\d+) (\d+) (\d+)$/)
 174     {
 175         if ($ccs_write) {
 176             print TEMPFILE ">>cost_centre_stack\n";
 177             $ccs_write = 0;
 178         }
 179         $ccs_id         = $1;
 180         $ccptr          = $2;
 181         $ccsptr         = $3;
 182         print TEMPFILE "$ccs_id $ccptr $ccsptr\n";
 183     }
 184     elsif (/^2 (\d+) (\d+) (\d+) (\d+)$/)
 185     {
 186         if ($ccs_write) {
 187             print TEMPFILE ">>cost_centre_stack\n";
 188             $ccs_write = 0;
 189         }
 190         $ccs_id         = $1;
 191         $type           = $2;
 192         $ccptr          = $3;
 193         $ccsptr         = $4;
 194         print TEMPFILE "$ccs_id $type $ccptr $ccsptr\n";
 195     }
 196     if (/^5 (\d+) (.*)$/)
 197     {
 198         if ($scc_write) {
 199             print TEMPFILE ">>scc_sample\n";
 200             $scc_write = 0;
 201         }
 202         $_              = $2;
 203         while (/^1 (\d+) (\d+) (\d+) (\d+) (.*)$/)
 204         {
 205             $rg1                = $1;
 206             $rg2                = $2;
 207             $rg3                = $3;
 208             $rg4                = $4;
 209             print TEMPFILE "$rg1 $rg2 $rg3 $rg4\n";
 210             $_          = $5;
 211         }
 212     }
 213 }
 214 print TEMPFILE ">>\n";
 215
 216 close(INPUT);
 217 close(TEMPFILE);
 218
 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;
 228 exec $cmd;
 229 exit(0);
 230
 231 sub readProfileHeader {
 232     local($found);
 233
 234     if (!open(PROFILE,$tempfile)) {
 235         printf STDERR "$Pgm: unable to open profile file \"$tempfile\".\n";
 236         $? = 1; tidy_up_and_die();
 237     }
 238     $found=0;
 239
 240     while(<PROFILE>) {
 241         if (/^F/) {
 242             if (/-prof/ && /-flibrary-level\s+(\d+)/) {
 243                 $libtype = "P$1";
 244             } elsif (/-flibrary-level\s+(\d+)/) {
 245                 $libtype = "O$1";
 246             }
 247             $found++;
 248
 249         } elsif (/^P\s*/) {
 250             $nprocs = int($');
 251             $found++;
 252
 253         } elsif (/^D\s*/) {
 254             chop($date = $');
 255             $found++;
 256
 257         } elsif (/^X\s*/) {
 258             chop($device = $');
 259         }
 260         last if ($found>=3);
 261     }
 262     close(PROFILE);
 263 }