Commit e29c2acc authored by Ben Gamari's avatar Ben Gamari 🐢

CoreUtils: Move seq* functions to CoreSeq

These seem to sit near the top of the import graph and have been causing
import cycles.
parent 02897c58
-- |
-- Various utilities for forcing Core structures
--
-- It can often be useful to force various parts of the AST. This module
-- provides a number of @seq@-like functions to accomplish this.
module CoreSeq (
-- * Utilities for forcing Core structures
seqExpr, seqExprs, seqUnfolding, seqRules,
megaSeqIdInfo, seqSpecInfo, seqBinds,
) where
import CoreSyn
import IdInfo
import Demand( seqDemand, seqStrictSig )
import BasicTypes( seqOccInfo )
import VarSet( seqVarSet )
import Var( varType, tyVarKind )
import Type( seqType, isTyVar )
import Coercion( seqCo )
import Id( Id, 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`
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` ()
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
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
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 _ = ()
......@@ -41,6 +41,7 @@ module CoreSubst (
import CoreSyn
import CoreFVs
import CoreSeq
import CoreUtils
import Literal ( Literal(MachStr) )
import qualified Data.ByteString as BS
......
......@@ -40,10 +40,6 @@ module CoreUtils (
-- * Eta reduction
tryEtaReduce,
-- * Seq
seqExpr, seqExprs, seqUnfolding, seqRules,
seqIdInfo, megaSeqIdInfo, seqSpecInfo, seqBinds,
-- * Manipulating data constructors and types
applyTypeToArgs, applyTypeToArg,
dataConRepInstPat, dataConRepFSInstPat,
......@@ -67,8 +63,6 @@ import Name
import Literal
import DataCon
import PrimOp
import Demand( seqDemand, seqStrictSig )
import BasicTypes( seqOccInfo )
import Id
import IdInfo
import Type
......@@ -1783,108 +1777,6 @@ 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` ()
{-
************************************************************************
* *
......
......@@ -259,6 +259,7 @@ Library
CoreTidy
CoreUnfold
CoreUtils
CoreSeq
MkCore
PprCore
Check
......
......@@ -490,6 +490,7 @@ compiler_stage2_dll0_MODULES = \
CoreTidy \
CoreUnfold \
CoreUtils \
CoreSeq \
CostCentre \
Ctype \
DataCon \
......
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