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
  50 $Verbose = 0;
  51 while ($#ARGV >= 0 && $ARGV[0] eq '-v' || $ARGV[0] =~ /^-genSPECS/) {
  52     if ($ARGV[0] eq '-v') {
  53         $Verbose = 1;
  54     } elsif ( $ARGV[0] eq '-genSPECS0' ) { # do it, but no SpecingString
  55         $SpecingString = '';
  56         @SpecingTypes = ();
  57         $DoGenSpecs = 1;
  58     } else {
  59         shift(@ARGV);
  60         $SpecingString = $ARGV[0];
  61         @SpecingTypes = split(/,/, $SpecingString);
  62         $DoGenSpecs = 1;
  63     }
  64     shift(@ARGV);
  65 }
  66 #ToDo: print a version number ?
  67
  68 $OrigCpp = '$(RAWCPP)';
  69
  70 if ( $OrigCpp =~ /(\S+)\s+(.*)/ ) {
  71     $cmd  = $1;
  72     $rest = $2;
  73     if ( -x $cmd ) { # cool
  74         $Cpp = $OrigCpp;
  75     } else { # oops; try to guess
  76         $GccV = `gcc -v 2>&1`;
  77         if ( $GccV =~ /Reading specs from (.*)\/specs/ ) {
  78             $Cpp = "$1/cpp $rest";
  79         } else {
  80             die "hscpp: don't know how to run cpp: $OrigCpp\n";
  81         }
  82     }
  83 } else {
  84     $Cpp = $OrigCpp;
  85 }
  86
  87 print STDERR "hscpp:CPP invoked: $Cpp @ARGV\n" if $Verbose;
  88
  89 open(INPIPE, "$Cpp @ARGV |") || die "Can't open C pre-processor pipe\n";
  90
  91 while (<INPIPE>) {
  92
  93 # line directives come in flavo[u]rs:
  94 #   s/^#\s*line\s+\d+$/\{\-# LINE \-\}/;   IGNORE THIS ONE FOR NOW
  95     s/^#\s*line\s+(\d+)\s+(\".+\")$/\{\-# LINE \1 \2 \-\}/;
  96     s/^#\s*(\d+)\s+(\".*\").*/\{\-# LINE \1 \2 \-\}/;
  97
  98 # genSPEC processing:
  99     if ( /^\s*\{-#\s*GENERATE_SPECS/ ) {
 100         if ( $DoGenSpecs ) {
 101             $data_or_inst = 0;
 102             $data_inst_str = "";
 103             $remove_poly = 1;
 104
 105             if ( /^\s*\{-#\s*GENERATE_SPECS\s+(data)\s+(\S.*)\s*::(.*)#-\}\s*$/ ) {
 106                 $data_or_inst = 1;
 107                 $data_inst_str = $1;
 108                 $vars = $2;
 109                 $type = $3;
 110             } elsif ( /^\s*\{-#\s*GENERATE_SPECS\s+(instance)\s+(\S.*)\s*::(.*)#-\}\s*$/ ) {
 111                 $data_or_inst = 1;
 112                 $data_inst_str = $1;
 113                 $vars = $2;
 114                 $type = $3;
 115             } elsif ( /^\s*\{-#\s*GENERATE_SPECS\s+(\S+)\s+(.*)\s*#-\}\s*$/ ) {
 116                 $line = $_;
 117                 $fun  = $1;
 118                 $vars = $2;
 119
 120                 $tysig = <INPIPE>;
 121                 while ( $tysig =~ /^\s*$/ ) {
 122                     print $tysig;
 123                     $tysig = <INPIPE>;
 124                 }
 125                 $funpat = $fun;                 # quote non alphanumeric characters in pattern
 126                 $funpat =~ s/(\W)/\\\1/g;
 127                 $tysig =~ /^\s*$funpat\s*::(.*)$/ || die "Error: GENERATE_SPECS not followed by type signature for $fun:\n$line$tysig\n";
 128                 $type = $1;
 129                 $type =~ s/^(.*)=>//;           # remove context from type
 130             } else {
 131                 die "Error: invlaid GENERATE_SPECS pragma:\n  $_";
 132             }
 133
 134             @tyvars = split(/\s+/, $vars);
 135             @tospec = ($type);
 136             foreach $var (@tyvars) {
 137                 @specing = @tospec;
 138
 139                 if ( $var =~ /^(\w+)\{(.*)\}$/ ) {
 140                     $var = $1;
 141                     @specing_types = split(/,/, $2);
 142                     if ($specing_types[0] eq '~') {
 143                         shift(@specing_types);
 144                         @tospec = ();           # remove specs polymorphic in this tyvar
 145                         $remove_poly = 0;
 146                     }
 147                     if ($specing_types[0] eq '+') {
 148                         shift(@specing_types);
 149                         unshift(@specing_types, @SpecingTypes);
 150                     }
 151                 } else {
 152                     @specing_types = @SpecingTypes;
 153                 }
 154
 155                 foreach $uty (@specing_types) {
 156                     @speced = @specing;
 157                     foreach $i (0..$#speced) {
 158                         $speced[$i] =~ s/\b$var\b/$uty/g ;
 159                     }
 160                     push(@tospec, @speced);
 161                 }
 162             }
 163             shift(@tospec) if $remove_poly;     # remove fully polymorphic spec
 164
 165             if ($#tospec >= 0) {
 166                 $specty = shift(@tospec);
 167                 print ($data_or_inst ? "{-# SPECIALIZE $data_inst_str $specty #-}" : "{-# SPECIALIZE $fun :: $specty");
 168                 while ($#tospec >= 0) {
 169                     $specty = shift(@tospec);
 170                     print ($data_or_inst ? "; {-# SPECIALIZE $data_inst_str $specty #-}" : ", $specty");
 171                 }
 172                 print ($data_or_inst ? "\n" : " #-}\n");
 173             } else {
 174                 print "{-# NO_SPECS_GENERATED ", $data_or_inst ? $specty : $fun, " #-}\n";
 175             }
 176             print $tysig if ! $data_or_inst;
 177         } else {
 178             print STDERR "Warning: GENERATE_SPECS pre-processing pragma ignored:\n  $_";
 179             print $_;
 180         }
 181     } else {
 182         print $_;
 183     }
 184 }
 185
 186 close(INPIPE) || exit(1); # exit is so we reflect any errors.