CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive,
+ InlineSpec(..), defaultInlineSpec, alwaysInlineSpec,
SuccessFlag(..), succeeded, failed, successIf
) where
| 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
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 )
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 ( (\\) )
-- 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 ->
(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 ->
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
--
= 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
; 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,
[(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
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 ;
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
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))
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
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 )
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
-- 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}
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
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
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
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}
\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
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
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}
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)
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)
"{-#" $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 }
| 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
import StaticFlags ( opt_SccProfilingOn )
import Type ( Kind, mkArrowKind, liftedTypeKind )
import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
- Activation(..) )
+ Activation(..), InlineSpec(..), defaultInlineSpec )
import OrdList
import Panic
'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 }
: {- 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)) }
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)) }
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
:: 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"
-- 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
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
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}
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 )
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
----------------
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]
-- 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
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}
= 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
-> 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
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
; 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
= 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)
-> 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
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}
%************************************************************************
import ListSetOps ( minusList )
import Outputable
import Bag
-import BasicTypes ( Activation( AlwaysActive ) )
+import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
import FastString
\end{code}
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
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 )
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 ()
; 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 {})
projects / ghc-hetmet.git / commitdiff