diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs
index 9641a0437e7199adb5bc50fcb07493126b6ee25b..5ddc45204a7317e3e5c9629a7b044e15465877f9 100644
--- a/ghc/compiler/basicTypes/BasicTypes.lhs
+++ b/ghc/compiler/basicTypes/BasicTypes.lhs
@@ -29,7 +29,7 @@ module BasicTypes(
TopLevelFlag(..), isTopLevel, isNotTopLevel,
- OccInfo(..), seqOccInfo, isFragileOccInfo,
+ OccInfo(..), seqOccInfo, isFragileOccInfo, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
OneBranch, oneBranch, notOneBranch
@@ -204,6 +204,10 @@ type OneBranch = Bool -- True <=> Occurs in only one case branch
oneBranch = True
notOneBranch = False
+isLoopBreaker :: OccInfo -> Bool
+isLoopBreaker IAmALoopBreaker = True
+isLoopBreaker other = False
+
isFragileOccInfo :: OccInfo -> Bool
isFragileOccInfo (OneOcc _ _) = True
isFragileOccInfo other = False
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 4089f3472d9d289c18796b7a77c0c9269bb61867..774877898ab28b2300b30b3e9e3a8a34cecefd4d 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -515,7 +515,7 @@ callSiteInline :: Bool -- True <=> the Id is black listed
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
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index d17e8b73d68325051b3eccea02a4e4858e93adf8..ce8adc2ebfdce6dc51d3fdf5abec39ff9a3b0f81 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -10,7 +10,7 @@
\begin{code}
module PprCore (
pprCoreExpr, pprParendExpr, pprIfaceUnfolding,
- pprCoreBinding, pprCoreBindings, pprIdBndr,
+ pprCoreBinding, pprCoreBindings,
pprCoreRules, pprCoreRule
) where
@@ -22,7 +22,7 @@ import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
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,
@@ -342,7 +342,7 @@ pprIdBndr id = ppr id <+>
(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}
@@ -355,16 +355,15 @@ ppIdInfo info
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
diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index ab51482543ddcef1ed8b677a70d3c02a71bdc917..62b33c6375a1ea00ef8bf4b8b4e9a93107a06598 100644
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -295,20 +295,21 @@ substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
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}
@@ -530,13 +531,12 @@ substWorker :: Subst -> WorkerInfo -> WorkerInfo
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
@@ -549,8 +549,7 @@ substRules subst rules
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)
@@ -560,13 +559,12 @@ substRules subst (Rules rules rhs_fvs)
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}
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 1e2897b2166ff36732d9282a056e0d68d63c03e1..21991ea247fa350f7a3e5f9272ea2be5fd05291b 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -14,7 +14,9 @@ import IO ( Handle, hPutStr, openFile,
hClose, hPutStrLn, IOMode(..) )
import HsSyn
-import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) )
+import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..),
+ OccInfo, isLoopBreaker
+ )
import RnMonad
import RnEnv ( availName )
@@ -32,7 +34,7 @@ import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo, InlinePragInfo(..), inli
strictnessInfo, ppStrictnessInfo, isBottomingStrictness,
cafInfo, ppCafInfo, specInfo,
cprInfo, ppCprInfo, pprInlinePragInfo,
- occInfo, OccInfo(..),
+ occInfo,
workerExists, workerInfo, ppWorkerInfo, WorkerInfo(..)
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..), rulesRules, rulesRhsFreeVars )
@@ -366,9 +368,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs
------------ 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
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 8c08c66b26fa2d6df38ae2e699fb7825941e5499..9f75c40658f7c2f1003fc7b49297a864b44061c8 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -36,7 +36,7 @@ import Id ( Id, idType, idInfo, idUnique, isDataConId, isDataConId_maybe,
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,
@@ -66,7 +66,7 @@ import Subst ( Subst, mkSubst, emptySubst, substTy, substExpr,
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
@@ -551,9 +551,16 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
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
@@ -980,8 +987,8 @@ postInlineUnconditionally :: Bool -- Black listed
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.
@@ -993,10 +1000,6 @@ postInlineUnconditionally black_listed occ_info bndr rhs
-- 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}