Commit 5eee6a1f authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Move seqExpr, seqIdInfo etc to CoreUtils

Refactoring only : it just brings some scattered "seq" code together
parent 928f536c
......@@ -198,7 +198,7 @@ lazySetIdInfo :: Id -> IdInfo -> Id
lazySetIdInfo = Var.lazySetIdInfo
setIdInfo :: Id -> IdInfo -> Id
setIdInfo id info = seqIdInfo info `seq` (lazySetIdInfo id info)
setIdInfo id info = info `seq` (lazySetIdInfo id info)
-- Try to avoid spack leaks by seq'ing
modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id
......
......@@ -15,7 +15,6 @@ module IdInfo (
-- * The IdInfo type
IdInfo, -- Abstract
vanillaIdInfo, noCafIdInfo,
seqIdInfo, megaSeqIdInfo,
-- ** The OneShotInfo type
OneShotInfo(..),
......@@ -56,7 +55,7 @@ module IdInfo (
SpecInfo(..),
emptySpecInfo,
isEmptySpecInfo, specInfoFreeVars,
specInfoRules, seqSpecInfo, setSpecInfoHead,
specInfoRules, setSpecInfoHead,
specInfo, setSpecInfo,
-- ** The CAFInfo type
......@@ -194,35 +193,6 @@ data IdInfo
-- n <=> all calls have at least n arguments
}
-- | Just evaluate the 'IdInfo' to WHNF
seqIdInfo :: IdInfo -> ()
seqIdInfo (IdInfo {}) = ()
-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the
-- compiler
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
= seqSpecInfo (specInfo info) `seq`
-- Omitting this improves runtimes a little, presumably because
-- some unfoldings are not calculated at all
-- seqUnfolding (unfoldingInfo info) `seq`
seqDemandInfo (demandInfo info) `seq`
seqStrictnessInfo (strictnessInfo info) `seq`
seqCaf (cafInfo info) `seq`
seqOneShot (oneShotInfo info) `seq`
seqOccInfo (occInfo info)
seqOneShot :: OneShotInfo -> ()
seqOneShot l = l `seq` ()
seqStrictnessInfo :: StrictSig -> ()
seqStrictnessInfo ty = seqStrictSig ty
seqDemandInfo :: Demand -> ()
seqDemandInfo dmd = seqDemand dmd
-- Setters
setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
......@@ -400,9 +370,6 @@ setSpecInfoHead :: Name -> SpecInfo -> SpecInfo
setSpecInfoHead fn (SpecInfo rules fvs)
= SpecInfo (map (setRuleIdName fn) rules) fvs
seqSpecInfo :: SpecInfo -> ()
seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
{-
************************************************************************
* *
......@@ -434,9 +401,6 @@ mayHaveCafRefs :: CafInfo -> Bool
mayHaveCafRefs MayHaveCafRefs = True
mayHaveCafRefs _ = False
seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()
instance Outputable CafInfo where
ppr = ppCafInfo
......
......@@ -58,9 +58,6 @@ module CoreSyn (
isClosedUnfolding, hasSomeUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
-- * Strictness
seqExpr, seqExprs, seqUnfolding,
-- * Annotated expression data types
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
......@@ -75,7 +72,7 @@ module CoreSyn (
RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
-- ** Operations on 'CoreRule's
seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
ruleArity, ruleName, ruleIdName, ruleActivation,
setRuleIdName,
isBuiltinRule, isLocalRule, isAutoRule,
......@@ -1023,19 +1020,6 @@ evaldUnfolding = OtherCon []
mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
uf_is_value = b1, uf_is_work_free = b2,
uf_expandable = b3, uf_is_conlike = b4,
uf_guidance = g})
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> ()
seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
seqGuidance _ = ()
isStableSource :: UnfoldingSource -> Bool
-- Keep the unfolding template
isStableSource InlineCompulsory = True
......@@ -1571,61 +1555,6 @@ valBndrCount = count isId
valArgCount :: [Arg b] -> Int
valArgCount = count isValArg
{-
************************************************************************
* *
\subsection{Seq stuff}
* *
************************************************************************
-}
seqExpr :: CoreExpr -> ()
seqExpr (Var v) = v `seq` ()
seqExpr (Lit lit) = lit `seq` ()
seqExpr (App f a) = seqExpr f `seq` seqExpr a
seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
seqExpr (Let b e) = seqBind b `seq` seqExpr e
seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
seqExpr (Cast e co) = seqExpr e `seq` seqCo co
seqExpr (Tick n e) = seqTickish n `seq` seqExpr e
seqExpr (Type t) = seqType t
seqExpr (Coercion co) = seqCo co
seqExprs :: [CoreExpr] -> ()
seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es
seqTickish :: Tickish Id -> ()
seqTickish ProfNote{ profNoteCC = cc } = cc `seq` ()
seqTickish HpcTick{} = ()
seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids
seqTickish SourceNote{} = ()
seqBndr :: CoreBndr -> ()
seqBndr b = b `seq` ()
seqBndrs :: [CoreBndr] -> ()
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
seqBind :: Bind CoreBndr -> ()
seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
seqBind (Rec prs) = seqPairs prs
seqPairs :: [(CoreBndr, CoreExpr)] -> ()
seqPairs [] = ()
seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
seqAlts :: [CoreAlt] -> ()
seqAlts [] = ()
seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
seqRules :: [CoreRule] -> ()
seqRules [] = ()
seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
= seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
seqRules (BuiltinRule {} : rules) = seqRules rules
{-
************************************************************************
* *
......
......@@ -39,6 +39,10 @@ module CoreUtils (
-- * Eta reduction
tryEtaReduce,
-- * Seq
seqExpr, seqExprs, seqUnfolding, seqRules,
seqIdInfo, megaSeqIdInfo, seqSpecInfo, seqBinds,
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
dataConRepInstPat, dataConRepFSInstPat,
......@@ -62,6 +66,8 @@ import Name
import Literal
import DataCon
import PrimOp
import Demand( seqDemand, seqStrictSig )
import BasicTypes( seqOccInfo )
import Id
import IdInfo
import Type
......@@ -1694,6 +1700,108 @@ locBind loc b1 b2 diffs = map addLoc diffs
bindLoc | b1 == b2 = ppr b1
| otherwise = ppr b1 <> char '/' <> ppr b2
{-
************************************************************************
* *
\subsection{Seq stuff}
* *
************************************************************************
-}
seqExpr :: CoreExpr -> ()
seqExpr (Var v) = v `seq` ()
seqExpr (Lit lit) = lit `seq` ()
seqExpr (App f a) = seqExpr f `seq` seqExpr a
seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
seqExpr (Let b e) = seqBind b `seq` seqExpr e
seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
seqExpr (Cast e co) = seqExpr e `seq` seqCo co
seqExpr (Tick n e) = seqTickish n `seq` seqExpr e
seqExpr (Type t) = seqType t
seqExpr (Coercion co) = seqCo co
seqExprs :: [CoreExpr] -> ()
seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es
seqTickish :: Tickish Id -> ()
seqTickish ProfNote{ profNoteCC = cc } = cc `seq` ()
seqTickish HpcTick{} = ()
seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids
seqTickish SourceNote{} = ()
seqBndr :: CoreBndr -> ()
seqBndr b | isTyVar b = seqType (tyVarKind b)
| otherwise = seqType (varType b) `seq`
megaSeqIdInfo (idInfo b)
seqBndrs :: [CoreBndr] -> ()
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
seqBinds :: [Bind CoreBndr] -> ()
seqBinds bs = foldr (seq . seqBind) () bs
seqBind :: Bind CoreBndr -> ()
seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
seqBind (Rec prs) = seqPairs prs
seqPairs :: [(CoreBndr, CoreExpr)] -> ()
seqPairs [] = ()
seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
seqAlts :: [CoreAlt] -> ()
seqAlts [] = ()
seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
seqRules :: [CoreRule] -> ()
seqRules [] = ()
seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
= seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
seqRules (BuiltinRule {} : rules) = seqRules rules
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
uf_is_value = b1, uf_is_work_free = b2,
uf_expandable = b3, uf_is_conlike = b4,
uf_guidance = g})
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> ()
seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
seqGuidance _ = ()
-- | Just evaluate the 'IdInfo' to WHNF
seqIdInfo :: IdInfo -> ()
seqIdInfo info = info `seq` ()
-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the
-- compiler
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
= seqSpecInfo (specInfo info) `seq`
-- Omitting this improves runtimes a little, presumably because
-- some unfoldings are not calculated at all
-- seqUnfolding (unfoldingInfo info) `seq`
seqDemand (demandInfo info) `seq`
seqStrictSig (strictnessInfo info) `seq`
seqCaf (cafInfo info) `seq`
seqOneShot (oneShotInfo info) `seq`
seqOccInfo (occInfo info)
seqOneShot :: OneShotInfo -> ()
seqOneShot l = l `seq` ()
seqSpecInfo :: SpecInfo -> ()
seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()
{-
************************************************************************
* *
......
......@@ -340,7 +340,7 @@ pprIdBndrInfo info
= sdocWithDynFlags $ \dflags ->
if gopt Opt_SuppressIdInfo dflags
then empty
else megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
else info `seq` doc -- The seq is useful for poking on black holes
where
prag_info = inlinePragInfo info
occ_info = occInfo info
......
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