From 9c30856ddafb6de78811cf5e8f1b9a8c773ddd5d Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 31 Oct 2005 11:49:30 +0000
Subject: [PATCH] [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.
---
 ghc/compiler/basicTypes/BasicTypes.lhs |    5 +++--
 ghc/compiler/parser/Parser.y.pp        |   14 ++++++++------
 ghc/compiler/parser/RdrHsSyn.lhs       |   11 +++++++++--
 3 files changed, 20 insertions(+), 10 deletions(-)

diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs
index 2cdf5ad..2527276 100644
--- 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
--- 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
--- 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
 
-- 
1.7.10.4