Commit 0666c3bb authored by simonpj's avatar simonpj
Browse files

[project @ 2000-04-21 14:40:48 by simonpj]

Remove a way to make the simplifier go into an
infinite loop.   This has been there for some weeks;
and George's UniForm tickled it.  I'm amazed nothing
else has done so.  I'll add a test.

The bad case happened when you go

	let xs = 1:xs
	in
	foldr k z xs

Then we kept firing the foldr/cons rule.

Solution: we don't attach an unfolding *at all* to
loop breakers (Simplify.completeBinding)
parent 7166525e
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......@@ -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
......
......@@ -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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment