Move more flags from the Makefile into pragmas

[ghc-hetmet.git] / compiler / parser / Parser.y.pp

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index c9e843e..d7971b4 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -8,6 +8,14 @@
 -- ---------------------------------------------------------------------------
 
 {
+{-# OPTIONS_GHC -O0 -fno-ignore-interface-pragmas #-}
+{-
+Careful optimisation of the parser: we don't want to throw everything
+at it, because that takes too long and doesn't buy much, but we do want
+to inline certain key external functions, so we instruct GHC not to
+throw away inlinings as it would normally do in -O0 mode.
+-}
+
 {-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
@@ -316,6 +324,7 @@ incorrect.
  PRIMCHAR      { L _ (ITprimchar   _) }
  PRIMSTRING    { L _ (ITprimstring _) }
  PRIMINTEGER   { L _ (ITprimint    _) }
+ PRIMWORD      { L _ (ITprimword  _) }
  PRIMFLOAT     { L _ (ITprimfloat  _) }
  PRIMDOUBLE    { L _ (ITprimdouble _) }
 
@@ -377,7 +386,7 @@ module      :: { Located (HsModule RdrName) }
                           Nothing)) }
 
 maybedocheader :: { (HaddockModInfo RdrName, Maybe (HsDoc RdrName)) }
-        : moduleheader            { (fst $1, snd $1) }
+        : moduleheader            { $1 }
         | {- empty -}             { (emptyHaddockModInfo, Nothing) }
 
 missing_module_keyword :: { () }
@@ -605,8 +614,8 @@ ty_decl :: { LTyClDecl RdrName }
        | data_or_newtype tycl_hdr constrs deriving
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms    -- no type pattern
-                     ; return $
-                         L (comb4 $1 $2 $3 $4)
+                     ; return $!
+                         sL (comb4 $1 $2 $3 $4)
                                   -- We need the location on tycl_hdr in case 
                                   -- constrs and deriving are both empty
                            (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
@@ -618,8 +627,8 @@ ty_decl :: { LTyClDecl RdrName }
                 deriving
                {% do { let {(ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms    -- can have type pats
-                     ; return $
-                         L (comb4 $1 $2 $4 $5)
+                     ; return $!
+                         sL (comb4 $1 $2 $4 $5)
                            (mkTyData (unLoc $1) (ctxt, tc, tvs, Nothing) 
                              (unLoc $3) (reverse (unLoc $5)) (unLoc $6)) } }
 
@@ -1308,8 +1317,8 @@ exp10 :: { LHsExpr RdrName }
 
 scc_annot :: { Located FastString }
        : '_scc_' STRING                        {% (addWarning Opt_WarnDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
-                                   (return $ LL $ getSTRING $2) }
-       | '{-# SCC' STRING '#-}'                { LL $ getSTRING $2 }
+                                   ( do scc <- getSCC $2; return $ LL scc ) }
+       | '{-# SCC' STRING '#-}'                {% do scc <- getSCC $2; return $ LL scc }
 
 hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
        : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
@@ -1862,6 +1871,7 @@ literal :: { Located HsLit }
        : CHAR                  { L1 $ HsChar       $ getCHAR $1 }
        | STRING                { L1 $ HsString     $ getSTRING $1 }
        | PRIMINTEGER           { L1 $ HsIntPrim    $ getPRIMINTEGER $1 }
+       | PRIMWORD              { L1 $ HsWordPrim    $ getPRIMWORD $1 }
        | PRIMCHAR              { L1 $ HsCharPrim   $ getPRIMCHAR $1 }
        | PRIMSTRING            { L1 $ HsStringPrim $ getPRIMSTRING $1 }
        | PRIMFLOAT             { L1 $ HsFloatPrim  $ getPRIMFLOAT $1 }
@@ -1955,6 +1965,7 @@ getRATIONAL       (L _ (ITrational x)) = x
 getPRIMCHAR    (L _ (ITprimchar   x)) = x
 getPRIMSTRING  (L _ (ITprimstring x)) = x
 getPRIMINTEGER (L _ (ITprimint    x)) = x
+getPRIMWORD    (L _ (ITprimword x)) = x
 getPRIMFLOAT   (L _ (ITprimfloat  x)) = x
 getPRIMDOUBLE  (L _ (ITprimdouble x)) = x
 getTH_ID_SPLICE (L _ (ITidEscape x)) = x
@@ -1966,6 +1977,14 @@ getDOCPREV (L _ (ITdocCommentPrev x)) = x
 getDOCNAMED (L _ (ITdocCommentNamed x)) = x
 getDOCSECTION (L _ (ITdocSection n x)) = (n, x)
 
+getSCC :: Located Token -> P FastString
+getSCC lt = do let s = getSTRING lt
+                   err = "Spaces are not allowed in SCCs"
+               -- We probably actually want to be more restrictive than this
+               if ' ' `elem` unpackFS s
+                   then failSpanMsgP (getLoc lt) (text err)
+                   else return s
+
 -- Utilities for combining source spans
 comb2 :: Located a -> Located b -> SrcSpan
 comb2 a b = a `seq` b `seq` combineLocs a b