summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/basicTypes/BasicTypes.lhs15
-rw-r--r--ghc/compiler/deSugar/DsBinds.lhs40
-rw-r--r--ghc/compiler/deSugar/DsMeta.hs4
-rw-r--r--ghc/compiler/deSugar/MatchCon.lhs4
-rw-r--r--ghc/compiler/hsSyn/Convert.lhs4
-rw-r--r--ghc/compiler/hsSyn/HsBinds.lhs85
-rw-r--r--ghc/compiler/hsSyn/HsDecls.lhs2
-rw-r--r--ghc/compiler/main/HscStats.lhs10
-rw-r--r--ghc/compiler/parser/Lexer.x20
-rw-r--r--ghc/compiler/parser/Parser.y.pp25
-rw-r--r--ghc/compiler/parser/RdrHsSyn.lhs2
-rw-r--r--ghc/compiler/rename/RnBinds.lhs18
-rw-r--r--ghc/compiler/rename/RnExpr.lhs2
-rw-r--r--ghc/compiler/rename/RnHsSyn.lhs4
-rw-r--r--ghc/compiler/rename/RnNames.lhs2
-rw-r--r--ghc/compiler/rename/RnSource.lhs2
-rw-r--r--ghc/compiler/typecheck/TcBinds.lhs21
-rw-r--r--ghc/compiler/typecheck/TcClassDcl.lhs6
-rw-r--r--ghc/compiler/typecheck/TcHsSyn.lhs10
-rw-r--r--ghc/compiler/typecheck/TcInstDcls.lhs4
-rw-r--r--ghc/compiler/typecheck/TcRnMonad.lhs10
-rw-r--r--ghc/compiler/typecheck/TcTyClsDecls.lhs4
22 files changed, 160 insertions, 134 deletions
diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs
index 4497bfdd89..2cdf5ad11c 100644
--- a/ghc/compiler/basicTypes/BasicTypes.lhs
+++ b/ghc/compiler/basicTypes/BasicTypes.lhs
@@ -48,6 +48,7 @@ module BasicTypes(
CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive,
+ InlineSpec(..), defaultInlineSpec, alwaysInlineSpec,
SuccessFlag(..), succeeded, failed, successIf
) where
@@ -466,12 +467,26 @@ data Activation = NeverActive
| ActiveAfter CompilerPhase -- Active in this phase and later
deriving( Eq ) -- Eq used in comparing rules in HsDecls
+data InlineSpec
+ = Inline
+ Activation -- Says during which phases inlining is allowed
+ Bool -- True <=> make the RHS look small, so that when inlining
+ -- is enabled, it will definitely actually happen
+ deriving( Eq )
+
+defaultInlineSpec = Inline AlwaysActive False -- Inlining is OK, but not forced
+alwaysInlineSpec = Inline AlwaysActive True -- Inline unconditionally
+
instance Outputable Activation where
ppr AlwaysActive = empty -- The default
ppr (ActiveBefore n) = brackets (char '~' <> int n)
ppr (ActiveAfter n) = brackets (int n)
ppr NeverActive = ptext SLIT("NEVER")
+instance Outputable InlineSpec where
+ ppr (Inline act True) = ptext SLIT("INLINE") <> ppr act
+ ppr (Inline act False) = ptext SLIT("NOINLINE") <> ppr act
+
isActive :: CompilerPhase -> Activation -> Bool
isActive p NeverActive = False
isActive p AlwaysActive = True
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 5be1774c31..70980f9785 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -28,9 +28,9 @@ import StaticFlags ( opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs )
import OccurAnal ( occurAnalyseExpr )
import CostCentre ( mkAutoCC, IsCafCC(..) )
-import Id ( Id, idType, idName, isExportedId, mkLocalId, setInlinePragma )
+import Id ( Id, DictId, idType, idName, isExportedId, mkLocalId, setInlinePragma )
import Rules ( addIdSpecialisations, mkLocalRule )
-import Var ( Var, isGlobalId, setIdNotExported )
+import Var ( TyVar, Var, isGlobalId, setIdNotExported )
import VarEnv
import Type ( mkTyVarTy, substTyWith )
import TysWiredIn ( voidTy )
@@ -38,7 +38,7 @@ import Outputable
import SrcLoc ( Located(..) )
import Maybes ( isJust, catMaybes, orElse )
import Bag ( bagToList )
-import BasicTypes ( Activation(..), isAlwaysActive )
+import BasicTypes ( Activation(..), InlineSpec(..), isAlwaysActive, defaultInlineSpec )
import Monad ( foldM )
import FastString ( mkFastString )
import List ( (\\) )
@@ -117,7 +117,6 @@ dsHsBind auto_scc rest
-- Always treat the binds as recursive, because the typechecker
-- makes rather mixed-up dictionary bindings
core_bind = Rec core_prs
- inline_env = mkVarEnv [(global, prag) | prag <- prags, isInlinePrag prag]
in
mappM (dsSpec all_tyvars dicts tyvars global local core_bind)
prags `thenDs` \ mb_specs ->
@@ -125,8 +124,11 @@ dsHsBind auto_scc rest
(spec_binds, rules) = unzip (catMaybes mb_specs)
global' = addIdSpecialisations global rules
rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+ inl = case [inl | InlinePrag inl <- prags] of
+ [] -> defaultInlineSpec
+ (inl:_) -> inl
in
- returnDs (addInlineInfo inline_env (global', rhs') : spec_binds ++ rest)
+ returnDs (addInlineInfo inl global' rhs' : spec_binds ++ rest)
dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
= ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
@@ -171,8 +173,15 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
returnDs ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest))
+dsSpec :: [TyVar] -> [DictId] -> [TyVar]
+ -> Id -> Id -- Global, local
+ -> CoreBind -> Prag
+ -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id
+ CoreRule)) -- Rule for the Global Id
+
-- Example:
-- f :: (Eq a, Ix b) => a -> b -> b
+-- {-# SPECIALISE f :: Ix b => Int -> b -> b #-}
--
-- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
--
@@ -190,9 +199,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {})
= return Nothing
dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
- (SpecPrag spec_expr spec_ty const_dicts)
+ (SpecPrag spec_expr spec_ty const_dicts inl)
= do { let poly_name = idName poly_id
- ; spec_name <- newLocalName (idName poly_id)
+ ; spec_name <- newLocalName poly_name
; ds_spec_expr <- dsExpr spec_expr
; let (bndrs, body) = collectBinders ds_spec_expr
mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body
@@ -200,7 +209,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
; case mb_lhs of
Nothing -> do { dsWarn msg; return Nothing }
- Just (bndrs', var, args) -> return (Just ((spec_id, spec_rhs), rule))
+ Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
where
local_poly = setIdNotExported poly_id
-- Very important to make the 'f' non-exported,
@@ -296,18 +305,19 @@ simpleSubst subst expr
[(c,bs,go r) | (c,bs,r) <- alts]
addLocalInlines exports core_prs
- = map (addInlineInfo inline_env) core_prs
+ = map add_inline core_prs
where
+ add_inline (bndr,rhs) | Just inl <- lookupVarEnv inline_env bndr
+ = addInlineInfo inl bndr rhs
+ | otherwise
+ = (bndr,rhs)
inline_env = mkVarEnv [(mono_id, prag)
| (_, _, mono_id, prags) <- exports,
- prag <- prags, isInlinePrag prag]
+ InlinePrag prag <- prags]
-addInlineInfo :: IdEnv Prag -> (Id,CoreExpr) -> (Id,CoreExpr)
-addInlineInfo inline_env (bndr,rhs)
- | Just (InlinePrag is_inline phase) <- lookupVarEnv inline_env bndr
+addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlineInfo (Inline phase is_inline) bndr rhs
= (attach_phase bndr phase, wrap_inline is_inline rhs)
- | otherwise
- = (bndr, rhs)
where
attach_phase bndr phase
| isAlwaysActive phase = bndr -- Default phase
diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 4f9f955765..40c0ce1ab4 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -343,8 +343,8 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-- Singleton => Ok
-- Empty => Too hard, signature ignored
-rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc
-rep_sig other = return []
+rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig other = return []
rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ;
diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs
index 7988c2cc98..90675fb419 100644
--- a/ghc/compiler/deSugar/MatchCon.lhs
+++ b/ghc/compiler/deSugar/MatchCon.lhs
@@ -12,9 +12,9 @@ import {-# SOURCE #-} Match ( match )
import HsSyn ( Pat(..), HsConDetails(..) )
import DsBinds ( dsLHsBinds )
-import DataCon ( isVanillaDataCon, dataConTyVars, dataConInstOrigArgTys )
+import DataCon ( isVanillaDataCon, dataConInstOrigArgTys )
import TcType ( tcTyConAppArgs )
-import Type ( substTys, zipTopTvSubst, mkTyVarTys )
+import Type ( mkTyVarTys )
import CoreSyn
import DsMonad
import DsUtils
diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index ab9cf2c278..a012cd14be 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -47,7 +47,7 @@ convertToHsDecls loc ds = map (cvt_top loc) ds
cvt_top :: SrcSpan -> TH.Dec -> Either (LHsDecl RdrName) Message
cvt_top loc d@(TH.ValD _ _ _) = Left $ L loc $ Hs.ValD (unLoc (cvtd loc d))
cvt_top loc d@(TH.FunD _ _) = Left $ L loc $ Hs.ValD (unLoc (cvtd loc d))
-cvt_top loc (TH.SigD nm typ) = Left $ L loc $ Hs.SigD (Sig (L loc (vName nm)) (cvtType loc typ))
+cvt_top loc (TH.SigD nm typ) = Left $ L loc $ Hs.SigD (TypeSig (L loc (vName nm)) (cvtType loc typ))
cvt_top loc (TySynD tc tvs rhs)
= Left $ L loc $ TyClD (TySynonym (L loc (tconName tc)) (cvt_tvs loc tvs) (cvtType loc rhs))
@@ -233,7 +233,7 @@ cvtBindsAndSigs loc ds
where
(sigs, non_sigs) = partition sigP ds
-cvtSig loc (TH.SigD nm typ) = L loc (Hs.Sig (L loc (vName nm)) (cvtType loc typ))
+cvtSig loc (TH.SigD nm typ) = L loc (Hs.TypeSig (L loc (vName nm)) (cvtType loc typ))
cvtds :: SrcSpan -> [TH.Dec] -> LHsBinds RdrName
cvtds loc [] = emptyBag
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 15f25f207d..f20bcb49d0 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -18,7 +18,7 @@ import {-# SOURCE #-} HsPat ( LPat )
import HsTypes ( LHsType, PostTcType )
import Name ( Name )
import NameSet ( NameSet, elemNameSet )
-import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity )
+import BasicTypes ( IPName, RecFlag(..), InlineSpec(..), Fixity )
import Outputable
import SrcLoc ( Located(..), SrcSpan, unLoc )
import Util ( sortLe )
@@ -277,15 +277,15 @@ serves for both.
type LSig name = Located (Sig name)
data Sig name
- = Sig (Located name) -- a bog-std type signature
+ = TypeSig (Located name) -- A bog-std type signature
(LHsType name)
- | SpecSig (Located name) -- specialise a function or datatype ...
+ | SpecSig (Located name) -- Specialise a function or datatype ...
(LHsType name) -- ... to these types
+ InlineSpec
- | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f
- (Located name) -- Function name
- Activation -- When inlining is *active*
+ | InlineSig (Located name) -- Function name
+ InlineSpec
| SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the
-- current instance decl
@@ -297,20 +297,20 @@ data FixitySig name = FixitySig (Located name) Fixity
-- A Prag conveys pragmas from the type checker to the desugarer
data Prag
- = InlinePrag
- Bool -- True <=> INLINE, False <=> NOINLINE
- Activation
+ = InlinePrag
+ InlineSpec
| SpecPrag
(HsExpr Id) -- An expression, of the given specialised type, which
PostTcType -- specialises the polymorphic function
[Id] -- Dicts mentioned free in the expression
+ InlineSpec -- Inlining spec for the specialised function
-isInlinePrag (InlinePrag _ _) = True
-isInlinePrag prag = False
+isInlinePrag (InlinePrag _) = True
+isInlinePrag prag = False
-isSpecPrag (SpecPrag _ _ _) = True
-isSpecPrag prag = False
+isSpecPrag (SpecPrag _ _ _ _) = True
+isSpecPrag prag = False
\end{code}
\begin{code}
@@ -318,9 +318,9 @@ okBindSig :: NameSet -> LSig Name -> Bool
okBindSig ns sig = sigForThisGroup ns sig
okHsBootSig :: LSig Name -> Bool
-okHsBootSig (L _ (Sig _ _)) = True
-okHsBootSig (L _ (FixSig _)) = True
-okHsBootSig sig = False
+okHsBootSig (L _ (TypeSig _ _)) = True
+okHsBootSig (L _ (FixSig _)) = True
+okHsBootSig sig = False
okClsDclSig :: LSig Name -> Bool
okClsDclSig (L _ (SpecInstSig _)) = False
@@ -329,7 +329,7 @@ okClsDclSig sig = True -- All others OK
okInstDclSig :: NameSet -> LSig Name -> Bool
okInstDclSig ns lsig@(L _ sig) = ok ns sig
where
- ok ns (Sig _ _) = False
+ ok ns (TypeSig _ _) = False
ok ns (FixSig _) = False
ok ns (SpecInstSig _) = True
ok ns sig = sigForThisGroup ns lsig
@@ -343,9 +343,9 @@ sigForThisGroup ns sig
sigName :: LSig name -> Maybe name
sigName (L _ sig) = f sig
where
- f (Sig n _) = Just (unLoc n)
- f (SpecSig n _) = Just (unLoc n)
- f (InlineSig _ n _) = Just (unLoc n)
+ f (TypeSig n _) = Just (unLoc n)
+ f (SpecSig n _ _) = Just (unLoc n)
+ f (InlineSig n _) = Just (unLoc n)
f (FixSig (FixitySig n _)) = Just (unLoc n)
f other = Nothing
@@ -354,26 +354,25 @@ isFixityLSig (L _ (FixSig _)) = True
isFixityLSig _ = False
isVanillaLSig :: LSig name -> Bool
-isVanillaLSig (L _(Sig name _)) = True
-isVanillaLSig sig = False
+isVanillaLSig (L _(TypeSig name _)) = True
+isVanillaLSig sig = False
isSpecLSig :: LSig name -> Bool
-isSpecLSig (L _(SpecSig name _)) = True
-isSpecLSig sig = False
+isSpecLSig (L _(SpecSig name _ _)) = True
+isSpecLSig sig = False
isSpecInstLSig (L _ (SpecInstSig _)) = True
isSpecInstLSig sig = False
isPragLSig :: LSig name -> Bool
-- Identifies pragmas
-isPragLSig (L _ (SpecSig _ _)) = True
-isPragLSig (L _ (InlineSig _ _ _)) = True
-isPragLSig other = False
-
-hsSigDoc (Sig _ _) = ptext SLIT("type signature")
-hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma")
-hsSigDoc (InlineSig True _ _) = ptext SLIT("INLINE pragma")
-hsSigDoc (InlineSig False _ _) = ptext SLIT("NOINLINE pragma")
+isPragLSig (L _ (SpecSig _ _ _)) = True
+isPragLSig (L _ (InlineSig _ _)) = True
+isPragLSig other = False
+
+hsSigDoc (TypeSig _ _) = ptext SLIT("type signature")
+hsSigDoc (SpecSig _ _ _) = ptext SLIT("SPECIALISE pragma")
+hsSigDoc (InlineSig _ spec) = ppr spec <+> ptext SLIT("pragma")
hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma")
hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
\end{code}
@@ -383,8 +382,8 @@ Signature equality is used when checking for duplicate signatures
\begin{code}
eqHsSig :: LSig Name -> LSig Name -> Bool
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
-eqHsSig (L _ (Sig n1 _)) (L _ (Sig n2 _)) = unLoc n1 == unLoc n2
-eqHsSig (L _ (InlineSig b1 n1 _)) (L _ (InlineSig b2 n2 _)) = b1 == b2 && unLoc n1 == unLoc n2
+eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2
+eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2)) = s1 == s2 && unLoc n1 == unLoc n2
-- For specialisations, we don't have equality over
-- HsType, so it's not convenient to spot duplicate
-- specialisations here. Check for this later, when we're in Type land
@@ -396,10 +395,10 @@ instance (OutputableBndr name) => Outputable (Sig name) where
ppr sig = ppr_sig sig
ppr_sig :: OutputableBndr name => Sig name -> SDoc
-ppr_sig (Sig var ty) = pprVarSig (unLoc var) ty
+ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty
ppr_sig (FixSig fix_sig) = ppr fix_sig
-ppr_sig (SpecSig var ty) = pragBrackets (pprSpec var ty)
-ppr_sig (InlineSig inl var phase) = pragBrackets (pprInline var inl phase)
+ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl)
+ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var)
ppr_sig (SpecInstSig ty) = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
instance Outputable name => Outputable (FixitySig name) where
@@ -408,17 +407,13 @@ instance Outputable name => Outputable (FixitySig name) where
pragBrackets :: SDoc -> SDoc
pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
-pprInline :: Outputable id => id -> Bool -> Activation -> SDoc
-pprInline var True phase = hsep [ptext SLIT("INLINE"), ppr phase, ppr var]
-pprInline var False phase = hsep [ptext SLIT("NOINLINE"), ppr phase, ppr var]
-
pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
-pprSpec :: (Outputable id, Outputable ty) => id -> ty -> SDoc
-pprSpec var ty = sep [ptext SLIT("SPECIALIZE") <+> pprVarSig var ty]
+pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
+pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
pprPrag :: Outputable id => id -> Prag -> SDoc
-pprPrag var (InlinePrag inl act) = pprInline var inl act
-pprPrag var (SpecPrag expr ty _) = pprSpec var ty
+pprPrag var (InlinePrag inl) = ppr inl <+> ppr var
+pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl
\end{code}
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index ddd11a662d..1f67f6e8a8 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -405,7 +405,7 @@ tyClDeclNames (TySynonym {tcdLName = name}) = [name]
tyClDeclNames (ForeignType {tcdLName = name}) = [name]
tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs})
- = cls_name : [n | L _ (Sig n _) <- sigs]
+ = cls_name : [n | L _ (TypeSig n _) <- sigs]
tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
= tc_name : conDeclsNames (map unLoc cons)
diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs
index b213764aa1..3d8566a859 100644
--- a/ghc/compiler/main/HscStats.lhs
+++ b/ghc/compiler/main/HscStats.lhs
@@ -105,11 +105,11 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
- sig_info (FixSig _) = (1,0,0,0)
- sig_info (Sig _ _) = (0,1,0,0)
- sig_info (SpecSig _ _) = (0,0,1,0)
- sig_info (InlineSig _ _ _) = (0,0,0,1)
- sig_info _ = (0,0,0,0)
+ sig_info (FixSig _) = (1,0,0,0)
+ sig_info (TypeSig _ _) = (0,1,0,0)
+ sig_info (SpecSig _ _ _) = (0,0,1,0)
+ sig_info (InlineSig _ _) = (0,0,0,1)
+ sig_info _ = (0,0,0,0)
import_info (L _ (ImportDecl _ _ qual as spec))
= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x
index 5351af140c..407b5fa516 100644
--- a/ghc/compiler/parser/Lexer.x
+++ b/ghc/compiler/parser/Lexer.x
@@ -175,12 +175,17 @@ $white_no_nl+ ;
"{-#" $whitechar* (RULES|rules) { token ITrules_prag }
<0,glaexts> {
+ "{-#" $whitechar* (INLINE|inline) { token (ITinline_prag True) }
+ "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
+ { token (ITinline_prag False) }
+ "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
+ { token ITspec_prag }
"{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
- { token ITspecialise_prag }
+ $whitechar* (INLINE|inline) { token (ITspec_inline_prag True) }
+ "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
+ $whitechar* (NO(T?)INLINE|no(t?)inline)
+ { token (ITspec_inline_prag False) }
"{-#" $whitechar* (SOURCE|source) { token ITsource_prag }
- "{-#" $whitechar* (INLINE|inline) { token ITinline_prag }
- "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
- { token ITnoinline_prag }
"{-#" $whitechar* (DEPRECATED|deprecated)
{ token ITdeprecated_prag }
"{-#" $whitechar* (SCC|scc) { token ITscc_prag }
@@ -350,10 +355,11 @@ data Token
| ITdotnet
| ITmdo
- | ITspecialise_prag -- Pragmas
+ -- Pragmas
+ | ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE
+ | ITspec_prag -- SPECIALISE
+ | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE)
| ITsource_prag
- | ITinline_prag
- | ITnoinline_prag
| ITrules_prag
| ITdeprecated_prag
| ITline_prag
diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp
index 6ad9f6bef6..e204d11003 100644
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -34,7 +34,7 @@ import Module
import StaticFlags ( opt_SccProfilingOn )
import Type ( Kind, mkArrowKind, liftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- Activation(..) )
+ Activation(..), InlineSpec(..), defaultInlineSpec )
import OrdList
import Panic
@@ -184,10 +184,10 @@ incorrect.
'proc' { L _ ITproc } -- for arrow notation extension
'rec' { L _ ITrec } -- for arrow notation extension
- '{-# SPECIALISE' { L _ ITspecialise_prag }
+ '{-# INLINE' { L _ (ITinline_prag _) }
+ '{-# SPECIALISE' { L _ ITspec_prag }
+ '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) }
'{-# SOURCE' { L _ ITsource_prag }
- '{-# INLINE' { L _ ITinline_prag }
- '{-# NOINLINE' { L _ ITnoinline_prag }
'{-# RULES' { L _ ITrules_prag }
'{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core
'{-# SCC' { L _ ITscc_prag }
@@ -537,10 +537,6 @@ activation :: { Activation } -- Omitted means AlwaysActive
: {- empty -} { AlwaysActive }
| explicit_activation { $1 }
-inverse_activation :: { Activation } -- Omitted means NeverActive
- : {- empty -} { NeverActive }
- | explicit_activation { $1 }
-
explicit_activation :: { Activation } -- In brackets
: '[' INTEGER ']' { ActiveAfter (fromInteger (getINTEGER $2)) }
| '[' '~' INTEGER ']' { ActiveBefore (fromInteger (getINTEGER $3)) }
@@ -996,16 +992,17 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
return (LL $ unitOL (LL $ SigD s)) }
-- See the above notes for why we need infixexp here
| var ',' sig_vars '::' sigtype
- { LL $ toOL [ LL $ SigD (Sig n $5) | n <- $1 : unLoc $3 ] }
+ { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
| 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 True $3 $2)) }
- | '{-# NOINLINE' inverse_activation qvar '#-}'
- { LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) }
+ { LL $ unitOL (LL $ SigD (InlineSig $3 (Inline $2 (getINLINE $1)))) }
| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
- { LL $ toOL [ LL $ SigD (SpecSig $2 t)
+ { 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)))
+ | t <- $5] }
| '{-# SPECIALISE' 'instance' inst_type '#-}'
{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
@@ -1573,6 +1570,8 @@ getPRIMINTEGER (L _ (ITprimint x)) = x
getPRIMFLOAT (L _ (ITprimfloat x)) = x
getPRIMDOUBLE (L _ (ITprimdouble x)) = x
getTH_ID_SPLICE (L _ (ITidEscape x)) = x
+getINLINE (L _ (ITinline_prag b)) = b
+getSPEC_INLINE (L _ (ITspec_inline_prag b)) = b
-- Utilities for combining source spans
comb2 :: Located a -> Located b -> SrcSpan
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index c8c29a1c52..6a478af334 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -601,7 +601,7 @@ checkValSig
:: LHsExpr RdrName
-> LHsType RdrName
-> P (Sig RdrName)
-checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
+checkValSig (L l (HsVar v)) ty | isUnqual v = return (TypeSig (L l v) ty)
checkValSig (L l other) ty
= parseError l "Type signature given for an expression"
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index f067e5d5d3..3c23aba712 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -188,7 +188,7 @@ rnTopBindsSrc binds@(ValBindsIn mbinds _)
-- Warn about missing signatures,
; let { ValBindsOut _ sigs' = binds'
- ; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs']
+ ; ty_sig_vars = mkNameSet [ unLoc n | L _ (TypeSig n _) <- sigs']
; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars }
; warn_missing_sigs <- doptM Opt_WarnMissingSigs
@@ -361,8 +361,8 @@ mkSigTvFn sigs
where
env :: NameEnv [Name]
env = mkNameEnv [ (name, map hsLTyVarName ltvs)
- | L _ (Sig (L _ name)
- (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs]
+ | L _ (TypeSig (L _ name)
+ (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs]
-- Note the pattern-match on "Explicit"; we only bind
-- type variables from signatures with an explicit top-level for-all
@@ -522,23 +522,23 @@ check_sigs ok_sig sigs
renameSig :: Sig RdrName -> RnM (Sig Name)
-- FixitSig is renamed elsewhere.
-renameSig (Sig v ty)
+renameSig (TypeSig v ty)
= lookupLocatedSigOccRn v `thenM` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
- returnM (Sig new_v new_ty)
+ returnM (TypeSig new_v new_ty)
renameSig (SpecInstSig ty)
= rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty ->
returnM (SpecInstSig new_ty)
-renameSig (SpecSig v ty)
+renameSig (SpecSig v ty inl)
= lookupLocatedSigOccRn v `thenM` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
- returnM (SpecSig new_v new_ty)
+ returnM (SpecSig new_v new_ty inl)
-renameSig (InlineSig b v p)
+renameSig (InlineSig v s)
= lookupLocatedSigOccRn v `thenM` \ new_v ->
- returnM (InlineSig b new_v p)
+ returnM (InlineSig new_v s)
\end{code}
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 59f70767fc..53a412f765 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -35,7 +35,7 @@ import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
negateName, thenMName, bindMName, failMName )
import Name ( Name, nameOccName, nameIsLocalOrFrom )
import NameSet
-import RdrName ( RdrName, emptyGlobalRdrEnv, plusGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
+import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
import LoadIface ( loadHomeInterface )
import UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 6ce037970f..8143a520ae 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -111,9 +111,9 @@ In all cases this is set up for interface-file declarations:
hsSigsFVs :: [LSig Name] -> FreeVars
hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
-hsSigFVs (Sig v ty) = extractHsTyNames ty
+hsSigFVs (TypeSig v ty) = extractHsTyNames ty
hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
-hsSigFVs (SpecSig v ty) = extractHsTyNames ty
+hsSigFVs (SpecSig v ty inl) = extractHsTyNames ty
hsSigFVs other = emptyFVs
----------------
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 1fddb33abd..bf6e54a4f5 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -351,7 +351,7 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name
- sig_hs_bndrs = [nm | L _ (Sig nm _) <- val_sigs]
+ sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs]
val_hs_bndrs = collectHsBindLocatedBinders val_decls
for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls]
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 84ff47d948..4bb9bd0bf0 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -504,7 +504,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
let
- sig_rdr_names_w_locs = [op | L _ (Sig op _) <- sigs]
+ sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
in
checkDupNames sig_doc sig_rdr_names_w_locs `thenM_`
-- Typechecker is responsible for checking that we only
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index a4d163a514..02bb9dfaa3 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -63,7 +63,7 @@ import Digraph ( SCC(..), stronglyConnComp )
import Maybes ( fromJust, isJust, isNothing, orElse, catMaybes )
import Util ( singleton )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
- RecFlag(..), isNonRec )
+ RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec )
import Outputable
\end{code}
@@ -117,7 +117,7 @@ tcHsBootSigs (ValBindsOut binds sigs)
= do { checkTc (null binds) badBootDeclErr
; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
where
- tc_boot_sig (Sig (L _ name) ty)
+ tc_boot_sig (TypeSig (L _ name) ty)
= do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
-- Notice that we make GlobalIds, not LocalIds
@@ -161,6 +161,9 @@ tcValBinds :: TopLevelFlag
-> HsValBinds Name -> TcM thing
-> TcM (HsValBinds TcId, thing)
+tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
+ = pprPanic "tcValBinds" (ppr binds)
+
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
= tcAddLetBoundTyVars binds $
-- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
@@ -431,18 +434,18 @@ tcPrags poly_id prags = mapM tc_prag prags
pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
tcPrag :: TcId -> Sig Name -> TcM Prag
-tcPrag poly_id (SpecSig orig_name hs_ty) = tcSpecPrag poly_id hs_ty
-tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty
-tcPrag poly_id (InlineSig inl _ act) = return (InlinePrag inl act)
+tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl
+tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec
+tcPrag poly_id (InlineSig v inl) = return (InlinePrag inl)
-tcSpecPrag :: TcId -> LHsType Name -> TcM Prag
-tcSpecPrag poly_id hs_ty
+tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
+tcSpecPrag poly_id hs_ty inl
= do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty
; (co_fn, lie) <- getLIE (tcSub spec_ty (idType poly_id))
; extendLIEs lie
; let const_dicts = map instToId lie
- ; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts) }
+ ; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts inl) }
--------------
-- If typechecking the binds fails, then return with each
@@ -887,7 +890,7 @@ tcTySigs sigs = do { mb_sigs <- mappM tcTySig (filter isVanillaLSig sigs)
; return (catMaybes mb_sigs) }
tcTySig :: LSig Name -> TcM (Maybe TcSigInfo)
-tcTySig (L span (Sig (L _ name) ty))
+tcTySig (L span (TypeSig (L _ name) ty))
= recoverM (return Nothing) $
setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index b5629683b4..b382af94df 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -118,8 +118,8 @@ tcClassSigs clas sigs def_methods
= do { dm_env <- checkDefaultBinds clas op_names def_methods
; mappM (tcClassSig dm_env) op_sigs }
where
- op_sigs = [sig | sig@(L _ (Sig _ _)) <- sigs]
- op_names = [n | sig@(L _ (Sig (L _ n) _)) <- op_sigs]
+ op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
+ op_names = [n | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
@@ -151,7 +151,7 @@ tcClassSig :: NameEnv Bool -- Info about default methods;
-> LSig Name
-> TcM TcMethInfo
-tcClassSig dm_env (L loc (Sig (L _ op_name) op_hs_ty))
+tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
= setSrcSpan loc $ do
{ op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
; let dm = case lookupNameEnv dm_env op_name of
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index a5d3f64479..fecc6d41ce 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -340,11 +340,11 @@ zonk_bind env (AbsBinds tyvars dicts exports val_binds)
zonkIdBndr env global `thenM` \ new_global ->
mapM zonk_prag prags `thenM` \ new_prags ->
returnM (new_tyvars, new_global, zonkIdOcc env local, new_prags)
- zonk_prag prag@(InlinePrag _ _) = return prag
- zonk_prag (SpecPrag expr ty ds) = do { expr' <- zonkExpr env expr
- ; ty' <- zonkTcTypeToType env ty
- ; let ds' = zonkIdOccs env ds
- ; return (SpecPrag expr' ty' ds') }
+ zonk_prag prag@(InlinePrag {}) = return prag
+ zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr
+ ; ty' <- zonkTcTypeToType env ty
+ ; let ds' = zonkIdOccs env ds
+ ; return (SpecPrag expr' ty' ds' inl) }
\end{code}
%************************************************************************
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 45117c2954..432d3c8cae 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -41,7 +41,7 @@ import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
import ListSetOps ( minusList )
import Outputable
import Bag
-import BasicTypes ( Activation( AlwaysActive ) )
+import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
import FastString
\end{code}
@@ -383,7 +383,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
scs_and_meths = map instToId sc_dicts ++ meth_ids
this_dict_id = instToId this_dict
inline_prag | null dfun_arg_dicts = []
- | otherwise = [InlinePrag True AlwaysActive]
+ | otherwise = [InlinePrag (Inline AlwaysActive True)]
-- Always inline the dfun; this is an experimental decision
-- because it makes a big performance difference sometimes.
-- Often it means we can do the method selection, and then
diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index d1d8528795..a4032cd16a 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -41,7 +41,7 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupp
import Unique ( Unique )
import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
import StaticFlags ( opt_PprStyle_Debug )
-import Bag ( snocBag, unionBags, unitBag )
+import Bag ( snocBag, unionBags )
import Panic ( showException )
import IO ( stderr )
@@ -448,14 +448,12 @@ addErrAt loc msg = addLongErrAt loc msg empty
addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
- = do { errs_var <- getErrsVar ;
+ = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
+
+ errs_var <- getErrsVar ;
rdr_env <- getGlobalRdrEnv ;
let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
(warns, errs) <- readMutVar errs_var ;
-
- let style = mkErrStyle (unQualInScope rdr_env)
- doc = mkLocMessage loc (msg $$ extra)
- in traceTc (ptext SLIT("Adding error:") <+> doc) ;
writeMutVar errs_var (warns, errs `snocBag` err) }
addErrs :: [(SrcSpan,Message)] -> TcRn ()
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index a10a74474c..5df15c10e8 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -324,8 +324,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs})
; sigs' <- mappM (wrapLocM kc_sig) sigs
; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
where
- kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
- ; return (Sig nm op_ty') }
+ kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+ ; return (TypeSig nm op_ty') }
kc_sig other_sig = return other_sig
kcTyClDecl decl@(ForeignType {})
View Lorry Controller Status