ghc/utils/hscpp/hscpp.prl

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