[project @ 2005-10-31 11:49:29 by simonpj]

Wibble to: "Add a new pragma: SPECIALISE INLINE"

I messed up the way that NOINLINE is parsed; this commit fixes it.

diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs
index 2cdf5ad..2527276 100644 (file)
--- a/ghc/compiler/basicTypes/BasicTypes.lhs
+++ b/ghc/compiler/basicTypes/BasicTypes.lhs
@@ -48,7 +48,7 @@ module BasicTypes(
 
        CompilerPhase, 
        Activation(..), isActive, isNeverActive, isAlwaysActive,
-       InlineSpec(..), defaultInlineSpec, alwaysInlineSpec,
+       InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec,
 
        SuccessFlag(..), succeeded, failed, successIf
    ) where
@@ -475,7 +475,8 @@ data InlineSpec
   deriving( Eq )
 
 defaultInlineSpec = Inline AlwaysActive False  -- Inlining is OK, but not forced
-alwaysInlineSpec  = Inline AlwaysActive True   -- Inline unconditionally
+alwaysInlineSpec  = Inline AlwaysActive True   -- INLINE always
+neverInlineSpec   = Inline NeverActive  False  -- NOINLINE 
 
 instance Outputable Activation where
    ppr AlwaysActive     = empty                -- The default

diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp
index e204d11..4a1519a 100644 (file)
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -531,11 +531,13 @@ rules     :: { OrdList (LHsDecl RdrName) }        -- Reversed
 
 rule   :: { LHsDecl RdrName }
        : STRING activation rule_forall infixexp '=' exp
-            { LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6) }
+            { LL $ RuleD (HsRule (getSTRING $1) 
+                                 ($2 `orElse` AlwaysActive) 
+                                 $3 $4 $6) }
 
-activation :: { Activation }           -- Omitted means AlwaysActive
-        : {- empty -}                           { AlwaysActive }
-        | explicit_activation                   { $1 }
+activation :: { Maybe Activation } 
+        : {- empty -}                           { Nothing }
+        | explicit_activation                   { Just $1 }
 
 explicit_activation :: { Activation }  -- In brackets
         : '[' INTEGER ']'              { ActiveAfter  (fromInteger (getINTEGER $2)) }
@@ -996,12 +998,12 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
        | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                             | n <- unLoc $3 ] }
        | '{-# INLINE'   activation qvar '#-}'        
-                               { LL $ unitOL (LL $ SigD (InlineSig $3 (Inline $2 (getINLINE $1)))) }
+                               { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 (getINLINE $1)))) }
        | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
                                { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
                                            | t <- $4] }
        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
-                               { LL $ toOL [ LL $ SigD (SpecSig $3 t (Inline $2 (getSPEC_INLINE $1)))
+                               { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 (getSPEC_INLINE $1)))
                                            | t <- $5] }
        | '{-# SPECIALISE' 'instance' inst_type '#-}'
                                { LL $ unitOL (LL $ SigD (SpecInstSig $3)) }

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 6a478af..e53ee14 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -11,7 +11,7 @@ module RdrHsSyn (
        mkHsOpApp, mkClassDecl, 
        mkHsNegApp, mkHsIntegral, mkHsFractional,
        mkHsDo, mkHsSplice,
-        mkTyData, mkPrefixCon, mkRecCon,
+        mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
 
        cvBindGroup,
@@ -53,7 +53,7 @@ import HsSyn          -- Lots of it
 import RdrName         ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, 
                          isRdrDataCon, isUnqual, getRdrName, isQual,
                          setRdrNameSpace )
-import BasicTypes      ( maxPrecedence )
+import BasicTypes      ( maxPrecedence, Activation, InlineSpec(..), alwaysInlineSpec, neverInlineSpec )
 import Lexer           ( P, failSpanMsgP )
 import TysWiredIn      ( unitTyCon ) 
 import ForeignCall     ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
@@ -671,6 +671,13 @@ mkRecConstrOrUpdate exp loc fs@(_:_)
 mkRecConstrOrUpdate _ loc []
   = parseError loc "Empty record update"
 
+mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+-- The Maybe is becuase the user can omit the activation spec (and usually does)
+mkInlineSpec Nothing   True  = alwaysInlineSpec        -- INLINE
+mkInlineSpec Nothing   False = neverInlineSpec         -- NOINLINE
+mkInlineSpec (Just act) inl   = Inline act inl
+
+
 -----------------------------------------------------------------------------
 -- utilities for foreign declarations