ghc/utils/hscpp/hscpp.prl

   1 eval "exec perl -S $0 $*"
   2      if $running_under_some_random_shell;
   3 #
   4 # reads CPP output and turns #line things into appropriate Haskell
   5 # pragmas
   6 #
   7 # considered to be GHC-project specific
   8 #
   9 #
  10 # OPTIONALLY processes GENERATE_SPECS pragmas
  11 # when give flag -genSPECS
  12 #
  13 # EXAMPLE:
  14 #
  15 # {-# GENERATE_SPECS a b #-}
  16 # fn :: type
  17 #
  18 #==>>
  19 #
  20 # fn :: type
  21 # {-# SPECIALIZE fn :: type[ a/a,u1/b] #-}
  22 # {-# SPECIALIZE fn :: type[ a/a,u2/b] #-}
  23 # {-# SPECIALIZE fn :: type[u1/a, b/b] #-}
  24 # {-# SPECIALIZE fn :: type[u1/a,u1/b] #-}
  25 # {-# SPECIALIZE fn :: type[u1/a,u2/b] #-}
  26 # {-# SPECIALIZE fn :: type[u2/a, b/b] #-}
  27 # {-# SPECIALIZE fn :: type[u2/a,u1/b] #-}
  28 # {-# SPECIALIZE fn :: type[u2/a,u2/b] #-}
  29 #
  30 # where the u's are extracted from a predetermined
  31 # set of unboxed types $SpecingString
  32 #
  33 # The types to substitute can be specified explicitly in { }s following
  34 # the type variable
  35 #
  36 # EXAMPLES:
  37 #
  38 # {-# GENERATE_SPECS a{ty1,ty2...} b{+,ty1,ty2...} c{~,ty1,ty2,...} d{~,+,ty1,ty2,...} #-}
  39 # fn :: type
  40 #
  41 # where
  42 #    ~ indicates that no specialisations are to be left polymorhphic in this type variable
  43 #      (this is required for overloaded tyvars which must have ground specialisations)
  44 #    + indicates that the predetermined types are to be added to the list
  45 #
  46 # Note: There must be no white space between { }s
  47 #       Use ( )s around type names when separation is required
  48
  49 $Verbose = 0;
  50
  51 $DoGenSpecs = 0;
  52 $DoGenSpecsUnboxed = 0;
  53 @SpecingTypes = ();
  54
  55 while ($#ARGV >= 0 && $ARGV[0] eq '-v' || $ARGV[0] =~ /^-genSPECS/) {
  56     if ($ARGV[0] eq '-v') {
  57         $Verbose = 1;
  58     } elsif ($ARGV[0] eq '-genSPECS') {
  59         $DoGenSpecs = 1;
  60     } elsif ($ARGV[0] eq '-genSPECSunboxed') {
  61         $DoGenSpecs = 1;
  62         $DoGenSpecsUnboxed = 1;
  63         $SpecingString = "Char#,Int#,Double#";
  64         @SpecingTypes = split(/,/, $SpecingString);
  65     } else {
  66         die "hscpp: unrecognised argument: $$ARGV[0]\n";
  67     }
  68     shift(@ARGV);
  69 }
  70 #ToDo: print a version number ?
  71
  72 $OrigCpp = '$(RAWCPP)';
  73
  74 if ( $OrigCpp =~ /(\S+)\s+(.*)/ ) {
  75     $cmd  = $1;
  76     $rest = $2;
  77     if ( -x $cmd ) { # cool
  78         $Cpp = $OrigCpp;
  79     } else { # oops; try to guess
  80         $GccV = `gcc -v 2>&1`;
  81         if ( $GccV =~ /Reading specs from (.*)\/specs/ ) {
  82             $Cpp = "$1/cpp $rest";
  83         } else {
  84             die "hscpp: don't know how to run cpp: $OrigCpp\n";
  85         }
  86     }
  87 } else {
  88     $Cpp = $OrigCpp;
  89 }
  90
  91 print STDERR "hscpp:CPP invoked: $Cpp @ARGV\n" if $Verbose;
  92
  93 open(INPIPE, "$Cpp @ARGV |") || die "Can't open C pre-processor pipe\n";
  94
  95 while (<INPIPE>) {
  96
  97 # line directives come in flavo[u]rs:
  98 #   s/^#\s*line\s+\d+$/\{\-# LINE \-\}/;   IGNORE THIS ONE FOR NOW
  99     s/^#\s*line\s+(\d+)\s+(\".+\")$/\{\-# LINE \1 \2 \-\}/;
 100     s/^#\s*(\d+)\s+(\".*\").*/\{\-# LINE \1 \2 \-\}/;
 101
 102 # genSPEC processing:
 103     if ( /^\s*\{-#\s*GENERATE_SPECS/ ) {
 104         if ( $DoGenSpecs ) {
 105             $line = $_;
 106             $data_or_inst = 0;
 107             $data_inst_str = "";
 108             $remove_poly = 1;
 109             $space = "";
 110
 111             if ( /^\s*\{-#\s*GENERATE_SPECS\s+(data)\s+(\S.*)\s*::(.*)#-\}\s*$/ ) {
 112                 $data_or_inst = 1;
 113                 $data_inst_str = $1;
 114                 $vars = $2;
 115                 $type = $3;
 116             } elsif ( /^\s*\{-#\s*GENERATE_SPECS\s+(instance)\s+(\S.*)\s*::(.*)#-\}\s*$/ ) {
 117                 $data_or_inst = 1;
 118                 $data_inst_str = $1;
 119                 $vars = $2;
 120                 $type = $3;
 121             } elsif ( /^(\s*)\{-#\s*GENERATE_SPECS\s+(\S+)\s+(.*)\s*#-\}\s*$/ ) {
 122                 $space = $1;
 123                 $fun  = $2;
 124                 $vars = $3;
 125
 126                 $tysig = <INPIPE>;
 127                 while ( $tysig =~ /^\s*$/ ) {
 128                     print $tysig;
 129                     $tysig = <INPIPE>;
 130                 }
 131                 $funpat = $fun;                 # quote non alphanumeric characters in pattern
 132                 $funpat =~ s/(\W)/\\\1/g;
 133                 $tysig =~ /^\s*$funpat\s*::(.*)$/ || die "Error: GENERATE_SPECS not followed by type signature for $fun:\n$line$tysig\n";
 134                 $type = $1;
 135                 $type =~ s/^(.*)=>//;           # remove context from type
 136             } else {
 137                 die "Error: invlaid GENERATE_SPECS pragma:\n  $_";
 138             }
 139
 140             @tyvars = split(/\s+/, $vars);
 141             @tospec = ($type);
 142             foreach $var (@tyvars) {
 143                 @specing = @tospec;
 144
 145                 if ( $var =~ /^(\w+)\{(.*)\}$/ ) {
 146                     $var = $1;
 147                     @specing_types = &split_types($2);
 148                     if ($specing_types[0] eq '~') {
 149                         shift(@specing_types);
 150                         @tospec = ();           # remove specs polymorphic in this tyvar
 151                         $remove_poly = 0;
 152                     }
 153                     if ($specing_types[0] eq '+') {
 154                         shift(@specing_types);
 155                         unshift(@specing_types, @SpecingTypes);
 156                     }
 157                 } else {
 158                     @specing_types = @SpecingTypes;
 159                 }
 160
 161                 # If not $DoGenSpecsUnboxed we remove any unboxed types
 162                 # (i.e. types containing a #) from the specing_types
 163
 164                 @specing_types = grep(!/#/, @specing_types) if ! $DoGenSpecsUnboxed;
 165
 166                 foreach $uty (@specing_types) {
 167                     @speced = @specing;
 168                     foreach $i (0..$#speced) {
 169                         $speced[$i] =~ s/\b$var\b/$uty/g ;
 170                     }
 171                     push(@tospec, @speced);
 172                 }
 173             }
 174             shift(@tospec) if $remove_poly;     # remove fully polymorphic spec
 175
 176             if ($#tospec >= 0) {
 177                 $specty = shift(@tospec);
 178                 print ($data_or_inst ? "{-# SPECIALIZE $data_inst_str $specty #-}" : "$space{-# SPECIALIZE $fun :: $specty");
 179                 while ($#tospec >= 0) {
 180                     $specty = shift(@tospec);
 181                     print ($data_or_inst ? "; {-# SPECIALIZE $data_inst_str $specty #-}" : ", $specty");
 182                 }
 183                 print ($data_or_inst ? "\n" : " #-}\n");
 184             } else {
 185                 print "{- NO_SPECS_GENERATED ", $data_or_inst ? $specty : $fun, " -}\n";
 186                 print STDERR "Warning: No specs for GENERATE_SPECS pre-processing pragma:\n  $_";
 187             }
 188             print $tysig if ! $data_or_inst;
 189         } else {
 190             print STDERR "Warning: GENERATE_SPECS pre-processing pragma ignored:\n  $_";
 191             print $_;
 192         }
 193     } else {
 194         print $_;
 195     }
 196 }
 197
 198 close(INPIPE) || exit(1); # exit is so we reflect any errors.
 199
 200 exit(0);
 201
 202
 203 # splits a list of types seperated by ,s but allowing ,s within ()s
 204
 205
 206 sub split_types {
 207     local($type_str) = @_;
 208
 209     local(@chars) = split(//,$type_str);
 210     local($depth) = 0;
 211     local($start) = 0;
 212     local($cur) = 0;
 213     local($char);
 214
 215     local(@types) = ();
 216
 217     while ($char = $chars[$cur]) {
 218         if ($char eq ',' && $depth == 0) {
 219             push(@types, join('', @chars[$start .. $cur-1])) if ($start < $cur);
 220             $start = $cur+1;
 221         } elsif ($char eq '(') {
 222             $depth++;
 223         } elsif ($char eq ')') {
 224             $depth--;
 225         }
 226         $cur++;
 227     }
 228     if ($depth == 0) {
 229         push(@types, join('', @chars[$start .. $cur-1])) if ($start < $cur);
 230     } else {
 231         print STDERR "Error: GENERATE_SPECS pre-processing pragma has unbalanced ( )s\n$line\n";
 232         exit(1);
 233     }
 234     return(@types);
 235 }
 236
 237
 238