Commit 958924a2 authored by simonpj's avatar simonpj

[project @ 2005-10-27 14:35:20 by simonpj]

Add a new pragma: SPECIALISE INLINE

This amounts to adding an INLINE pragma to the specialised version
of the function.  You can add phase stuff too (SPECIALISE INLINE [2]),
and NOINLINE instead of INLINE.

The reason for doing this is to support inlining of type-directed
recursive functions.  The main example is this:

  -- non-uniform array type
  data Arr e where
    ArrInt  :: !Int -> ByteArray#       -> Arr Int
    ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)

  (!:) :: Arr e -> Int -> e
  {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
  {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
  ArrInt  _ ba    !: (I# i) = I# (indexIntArray# ba i)
  ArrPair _ a1 a2 !: i      = (a1 !: i, a2 !: i)

If we use (!:) at a particular array type, we want to inline (:!),
which is recursive, until all the type specialisation is done.


On the way I did a bit of renaming and tidying of the way that
pragmas are carried, so quite a lot of files are touched in a
fairly trivial way.
parent 47d253ba
......@@ -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
......
......@@ -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
......
......@@ -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 ;
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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}
......
......@@ -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 )
......
......@@ -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
----------------
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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 ()
......
......@@ -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 {})
......