TopLevelFlag(..), isTopLevel, isNotTopLevel,
- OccInfo(..), seqOccInfo, isFragileOccInfo,
+ OccInfo(..), seqOccInfo, isFragileOccInfo, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch
oneBranch = True
notOneBranch = False
+isLoopBreaker :: OccInfo -> Bool
+isLoopBreaker IAmALoopBreaker = True
+isLoopBreaker other = False
+
isFragileOccInfo :: OccInfo -> Bool
isFragileOccInfo (OneOcc _ _) = True
isFragileOccInfo other = False
callSiteInline black_listed inline_call occ id arg_infos interesting_cont
= case idUnfolding id of {
NoUnfolding -> Nothing ;
- OtherCon _ -> Nothing ;
+ OtherCon cs -> Nothing ;
CompulsoryUnfolding unf_template | black_listed -> Nothing
| otherwise -> Just unf_template ;
-- Constructors have compulsory unfoldings, but
\begin{code}
module PprCore (
pprCoreExpr, pprParendExpr, pprIfaceUnfolding,
- pprCoreBinding, pprCoreBindings, pprIdBndr,
+ pprCoreBinding, pprCoreBindings,
pprCoreRules, pprCoreRule
) where
idInfo, idInlinePragma, idDemandInfo, idOccInfo
)
import Var ( isTyVar )
-import IdInfo ( IdInfo, megaSeqIdInfo,
+import IdInfo ( IdInfo, megaSeqIdInfo, occInfo,
arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
demandInfo, updateInfo, ppUpdateInfo, specInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
(megaSeqIdInfo (idInfo id) `seq`
-- Useful for poking on black holes
ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
- ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
+ ppr (idDemandInfo id)) <+> ppr (idLBVarInfo id))
\end{code}
ppUpdateInfo u,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
- ppr d,
ppCafInfo c,
ppCprInfo m,
- ppr (lbvarInfo info),
pprIfaceCoreRules p
- -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
+ -- Inline pragma, occ, demand, lbvar info
+ -- printed out with all binders (when debug is on);
+ -- see PprCore.pprIdBndr
]
where
a = arityInfo info
- d = demandInfo info
s = strictnessInfo info
u = updateInfo info
c = cafInfo info
subst_ty subst ty
= go ty
where
- go (TyConApp tc tys) = let args = map go tys
- in args `seqList` TyConApp tc args
- go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
- go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
+ go (TyConApp tc tys) = let args = map go tys
+ in args `seqList` TyConApp tc args
+ go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote $! (go ty1)) $! (go ty2)
+ go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
go (NoteTy (UsgNote usg) ty2) = (NoteTy $! UsgNote usg) $! go ty2 -- Keep usage annot
go (NoteTy (UsgForAll uv) ty2) = (NoteTy $! UsgForAll uv) $! go ty2 -- Keep uvar bdr
go (NoteTy (IPNote nm) ty2) = (NoteTy $! IPNote nm) $! go ty2 -- Keep ip note
- go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
- go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
+
+ go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
+ go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
+ go ty@(TyVarTy tv) = case (lookupSubst subst tv) of
Nothing -> ty
Just (DoneTy ty') -> ty'
- go (ForAllTy tv ty) = case substTyVar subst tv of
+ go (ForAllTy tv ty) = case substTyVar subst tv of
(subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty)
\end{code}
substWorker subst NoWorker
= NoWorker
substWorker subst (HasWorker w a)
- = case lookupSubst subst w of
- Nothing -> HasWorker w a
- Just (DoneId w1 _) -> HasWorker w1 a
- Just (DoneEx (Var w1)) -> HasWorker w1 a
- Just (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
+ = case lookupIdSubst subst w of
+ (DoneId w1 _) -> HasWorker w1 a
+ (DoneEx (Var w1)) -> HasWorker w1 a
+ (DoneEx other) -> WARN( True, text "substWorker: DoneEx" <+> ppr w )
NoWorker -- Worker has got substituted away altogether
- Just (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
+ (ContEx se1 e) -> WARN( True, text "substWorker: ContEx" <+> ppr w <+> ppr e)
NoWorker -- Ditto
substRules :: Subst -> CoreRules -> CoreRules
substRules subst (Rules rules rhs_fvs)
= seqRules new_rules `seq` new_rules
where
- new_rules = Rules (map do_subst rules)
- (subst_fvs (substEnv subst) rhs_fvs)
+ new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs)
do_subst rule@(BuiltinRule _) = rule
do_subst (Rule name tpl_vars lhs_args rhs)
where
(subst', tpl_vars') = substBndrs subst tpl_vars
- subst_fvs se fvs
- = foldVarSet (unionVarSet . subst_fv) emptyVarSet rhs_fvs
- where
- subst_fv fv = case lookupSubstEnv se fv of
- Nothing -> unitVarSet fv
- Just (DoneId fv' _) -> unitVarSet fv'
- Just (DoneEx expr) -> exprFreeVars expr
- Just (DoneTy ty) -> tyVarsOfType ty
- Just (ContEx se' expr) -> subst_fvs se' (exprFreeVars expr)
+substVarSet subst fvs
+ = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
+ where
+ subst_fv subst fv = case lookupIdSubst subst fv of
+ DoneId fv' _ -> unitVarSet fv'
+ DoneEx expr -> exprFreeVars expr
+ DoneTy ty -> tyVarsOfType ty
+ ContEx se' expr -> substVarSet (setSubstEnv subst se') (exprFreeVars expr)
\end{code}
hClose, hPutStrLn, IOMode(..) )
import HsSyn
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..),
+ OccInfo, isLoopBreaker
+ )
import RnMonad
import RnEnv ( availName )
strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
cafInfo, ppCafInfo, specInfo,
cprInfo, ppCprInfo, pprInlinePragInfo,
- occInfo, OccInfo(..),
+ occInfo,
workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..)
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
------------ Occ info --------------
- loop_breaker = case occInfo core_idinfo of
- IAmALoopBreaker -> True
- other -> False
+ loop_breaker = isLoopBreaker (occInfo core_idinfo)
------------ Unfolding --------------
inline_pragma = inlinePragInfo core_idinfo
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
specInfo, inlinePragInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo,
- CprInfo(..), cprInfo
+ CprInfo(..), cprInfo, occInfo
)
import Demand ( Demand, isStrict, wwLazy )
import DataCon ( DataCon, dataConNumInstArgs, dataConRepStrictness, dataConRepArity,
import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
-import BasicTypes ( TopLevelFlag(..), isTopLevel )
+import BasicTypes ( TopLevelFlag(..), isTopLevel, isLoopBreaker )
import Maybes ( maybeToBool )
import Util ( zipWithEqual, lengthExceeds )
import PprCore
old_info = idInfo old_bndr
new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
`setArityInfo` ArityAtLeast (exprArity new_rhs)
- `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
- final_id = new_bndr `setIdInfo` new_bndr_info
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing we can get into an infinite loop
+ info_w_unf | isLoopBreaker (occInfo old_info) = new_bndr_info
+ | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
+
+ final_id = new_bndr `setIdInfo` info_w_unf
in
-- These seqs forces the Id, and hence its IdInfo,
-- and hence any inner substitutions
postInlineUnconditionally black_listed occ_info bndr rhs
| isExportedId bndr ||
black_listed ||
- loop_breaker = False -- Don't inline these
- | otherwise = exprIsTrivial rhs -- Duplicating is free
+ isLoopBreaker occ_info = False -- Don't inline these
+ | otherwise = exprIsTrivial rhs -- Duplicating is free
-- Don't inline even WHNFs inside lambdas; doing so may
-- simply increase allocation when the function is called
-- This isn't the last chance; see NOTE above.
-- NB: Even NOINLINEis ignored here: if the rhs is trivial
-- it's best to inline it anyway. We often get a=E; b=a
-- from desugaring, with both a and b marked NOINLINE.
- where
- loop_breaker = case occ_info of
- IAmALoopBreaker -> True
- other -> False
\end{code}
projects / ghc-hetmet.git / commitdiff