module SimplMonad (
InId, InBind, InExpr, InAlt, InArg, InType, InBinder,
OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
- OutExprStuff, OutStuff,
+ OutExprStuff, OutStuff, returnOutStuff,
-- The monad
SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
+ getDOptsSmpl,
-- The inlining black-list
setBlackList, getBlackList, noInlineBlackList,
-- Unique supply
- getUniqueSmpl, getUniquesSmpl,
+ getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl,
newId, newIds,
-- Counting
getSubstEnv, extendSubst, extendSubstList,
getInScope, setInScope, modifyInScope, addNewInScopeIds,
setSubstEnv, zapSubstEnv,
- getSimplBinderStuff, setSimplBinderStuff
+ getSimplBinderStuff, setSimplBinderStuff,
+
+ -- Adding bindings
+ addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds,
+ addCaseBind, needsCaseBinding, addNonRecBind, wrapFloats, addFloats
) where
#include "HsVersions.h"
-import Id ( Id, mkSysLocal, idUnfolding, isDataConWrapId )
+import Id ( Id, mkSysLocal, idType, idUnfolding, isDataConWrapId,
+ isGlobalId )
import CoreSyn
import CoreUnfold ( isCompulsoryUnfolding )
+import CoreUtils ( exprOkForSpeculation )
import PprCore () -- Instances
import CostCentre ( CostCentreStack, subsumedCCS )
-import Name ( isLocallyDefined )
import OccName ( UserFS )
import VarEnv
import VarSet
+import OrdList
import qualified Subst
import Subst ( Subst, mkSubst, substEnv,
- InScopeSet, mkInScopeSet, substInScope, isInScope
+ InScopeSet, mkInScopeSet, substInScope,
+ isInScope
)
-import Type ( Type )
+import Type ( Type, isUnLiftedType )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
import FiniteMap
import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
- opt_PprStyle_Debug, opt_HistorySize, opt_D_dump_simpl_stats,
+ DynFlags, DynFlag(..), dopt,
+ opt_PprStyle_Debug, opt_HistorySize,
intSwitchSet
)
import Unique ( Unique )
type SwitchChecker = SimplifierSwitch -> SwitchResult
-type OutExprStuff = OutStuff (InScopeSet, OutExpr)
-type OutStuff a = ([OutBind], a)
+type OutExprStuff = OutStuff OutExpr
+type OutStuff a = (OrdList OutBind, (InScopeSet, a))
-- We return something equivalent to (let b in e), but
-- in pieces to avoid the quadratic blowup when floating
-- incrementally. Comments just before simplExprB in Simplify.lhs
\end{code}
+\begin{code}
+wrapFloats :: OrdList CoreBind -> CoreExpr -> CoreExpr
+wrapFloats binds body = foldOL Let body binds
+
+returnOutStuff :: a -> SimplM (OutStuff a)
+returnOutStuff x = getInScope `thenSmpl` \ in_scope ->
+ returnSmpl (nilOL, (in_scope, x))
+
+addFloats :: OrdList CoreBind -> InScopeSet -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+addFloats floats in_scope thing_inside
+ = setInScope in_scope thing_inside `thenSmpl` \ (binds, res) ->
+ returnSmpl (floats `appOL` binds, res)
+
+addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+addLetBind bind thing_inside
+ = thing_inside `thenSmpl` \ (binds, res) ->
+ returnSmpl (bind `consOL` binds, res)
+
+addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+addLetBinds binds1 thing_inside
+ = thing_inside `thenSmpl` \ (binds2, res) ->
+ returnSmpl (toOL binds1 `appOL` binds2, res)
+
+addAuxiliaryBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+ -- Extends the in-scope environment as well as wrapping the bindings
+addAuxiliaryBinds binds1 thing_inside
+ = addNewInScopeIds (bindersOfBinds binds1) $
+ addLetBinds binds1 thing_inside
+
+addAuxiliaryBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+ -- Extends the in-scope environment as well as wrapping the bindings
+addAuxiliaryBind bind thing_inside
+ = addNewInScopeIds (bindersOf bind) $
+ addLetBind bind thing_inside
+
+needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
+ -- Make a case expression instead of a let
+ -- These can arise either from the desugarer,
+ -- or from beta reductions: (\x.e) (x +# y)
+
+addCaseBind bndr rhs thing_inside
+ = thing_inside `thenSmpl` \ (floats, (_, body)) ->
+ returnOutStuff (Case rhs bndr [(DEFAULT, [], wrapFloats floats body)])
+
+addNonRecBind bndr rhs thing_inside
+ -- Checks for needing a case binding
+ | needsCaseBinding (idType bndr) rhs = addCaseBind bndr rhs thing_inside
+ | otherwise = addLetBind (NonRec bndr rhs) thing_inside
+\end{code}
+
%************************************************************************
%* *
(Command-line switches move around through the explicitly-passed SimplEnv.)
\begin{code}
-type SimplM result -- We thread the unique supply because
- = SimplEnv -- constantly splitting it is rather expensive
- -> UniqSupply
+type SimplM result
+ = DynFlags
+ -> SimplEnv -- We thread the unique supply because
+ -> UniqSupply -- constantly splitting it is rather expensive
-> SimplCount
-> (result, UniqSupply, SimplCount)
\end{code}
\begin{code}
-initSmpl :: SwitchChecker
+initSmpl :: DynFlags
+ -> SwitchChecker
-> UniqSupply -- No init count; set to 0
-> VarSet -- In scope (usually empty, but useful for nested calls)
-> BlackList -- Black-list function
-> SimplM a
-> (a, SimplCount)
-initSmpl chkr us in_scope black_list m
- = case m (emptySimplEnv chkr in_scope black_list) us zeroSimplCount of
+initSmpl dflags chkr us in_scope black_list m
+ = case m dflags (emptySimplEnv chkr in_scope black_list) us
+ (zeroSimplCount dflags) of
(result, _, count) -> (result, count)
{-# INLINE returnSmpl #-}
returnSmpl :: a -> SimplM a
-returnSmpl e env us sc = (e, us, sc)
+returnSmpl e dflags env us sc = (e, us, sc)
thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b
thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
-thenSmpl m k env us0 sc0
- = case (m env us0 sc0) of
- (m_result, us1, sc1) -> k m_result env us1 sc1
+thenSmpl m k dflags env us0 sc0
+ = case (m dflags env us0 sc0) of
+ (m_result, us1, sc1) -> k m_result dflags env us1 sc1
-thenSmpl_ m k env us0 sc0
- = case (m env us0 sc0) of
- (_, us1, sc1) -> k env us1 sc1
+thenSmpl_ m k dflags env us0 sc0
+ = case (m dflags env us0 sc0) of
+ (_, us1, sc1) -> k dflags env us1 sc1
\end{code}
%************************************************************************
\begin{code}
-getUniqueSmpl :: SimplM Unique
-getUniqueSmpl env us sc = case splitUniqSupply us of
- (us1, us2) -> (uniqFromSupply us1, us2, sc)
+getUniqSupplySmpl :: SimplM UniqSupply
+getUniqSupplySmpl dflags env us sc
+ = case splitUniqSupply us of
+ (us1, us2) -> (us1, us2, sc)
-getUniquesSmpl :: Int -> SimplM [Unique]
-getUniquesSmpl n env us sc = case splitUniqSupply us of
- (us1, us2) -> (uniqsFromSupply n us1, us2, sc)
+getUniqueSmpl :: SimplM Unique
+getUniqueSmpl dflags env us sc
+ = case splitUniqSupply us of
+ (us1, us2) -> (uniqFromSupply us1, us2, sc)
+
+getUniquesSmpl :: SimplM [Unique]
+getUniquesSmpl dflags env us sc
+ = case splitUniqSupply us of
+ (us1, us2) -> (uniqsFromSupply us1, us2, sc)
+
+getDOptsSmpl :: SimplM DynFlags
+getDOptsSmpl dflags env us sc
+ = (dflags, us, sc)
\end{code}
\begin{code}
getSimplCount :: SimplM SimplCount
-getSimplCount env us sc = (sc, us, sc)
+getSimplCount dflags env us sc = (sc, us, sc)
tick :: Tick -> SimplM ()
-tick t env us sc = sc' `seq` ((), us, sc')
- where
- sc' = doTick t sc
+tick t dflags env us sc
+ = sc' `seq` ((), us, sc')
+ where
+ sc' = doTick t sc
freeTick :: Tick -> SimplM ()
-- Record a tick, but don't add to the total tick count, which is
-- used to decide when nothing further has happened
-freeTick t env us sc = sc' `seq` ((), us, sc')
- where
- sc' = doFreeTick t sc
+freeTick t dflags env us sc
+ = sc' `seq` ((), us, sc')
+ where
+ sc' = doFreeTick t sc
\end{code}
\begin{code}
verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
-zeroSimplCount :: SimplCount
+zeroSimplCount :: DynFlags -> SimplCount
isZeroSimplCount :: SimplCount -> Bool
pprSimplCount :: SimplCount -> SDoc
doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
type TickCounts = FiniteMap Tick Int
-zeroSimplCount -- This is where we decide whether to do
+zeroSimplCount dflags
+ -- This is where we decide whether to do
-- the VerySimpl version or the full-stats version
- | opt_D_dump_simpl_stats = SimplCount {ticks = 0, details = emptyFM,
- n_log = 0, log1 = [], log2 = []}
- | otherwise = VerySimplZero
+ | dopt Opt_D_dump_simpl_stats dflags
+ = SimplCount {ticks = 0, details = emptyFM,
+ n_log = 0, log1 = [], log2 = []}
+ | otherwise
+ = VerySimplZero
isZeroSimplCount VerySimplZero = True
isZeroSimplCount (SimplCount { ticks = 0 }) = True
| UnfoldingDone Id
| RuleFired FAST_STRING -- Rule name
- | LetFloatFromLet Id -- Thing floated out
+ | LetFloatFromLet
| EtaExpansion Id -- LHS binder
| EtaReduction Id -- Binder on outer lambda
| BetaReduction Id -- Lambda binder
tickToTag (PostInlineUnconditionally _) = 1
tickToTag (UnfoldingDone _) = 2
tickToTag (RuleFired _) = 3
-tickToTag (LetFloatFromLet _) = 4
+tickToTag LetFloatFromLet = 4
tickToTag (EtaExpansion _) = 5
tickToTag (EtaReduction _) = 6
tickToTag (BetaReduction _) = 7
tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
tickString (UnfoldingDone _) = "UnfoldingDone"
tickString (RuleFired _) = "RuleFired"
-tickString (LetFloatFromLet _) = "LetFloatFromLet"
+tickString LetFloatFromLet = "LetFloatFromLet"
tickString (EtaExpansion _) = "EtaExpansion"
tickString (EtaReduction _) = "EtaReduction"
tickString (BetaReduction _) = "BetaReduction"
pprTickCts (PostInlineUnconditionally v)= ppr v
pprTickCts (UnfoldingDone v) = ppr v
pprTickCts (RuleFired v) = ppr v
-pprTickCts (LetFloatFromLet v) = ppr v
+pprTickCts LetFloatFromLet = empty
pprTickCts (EtaExpansion v) = ppr v
pprTickCts (EtaReduction v) = ppr v
pprTickCts (BetaReduction v) = ppr v
cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
-cmpEqTick (LetFloatFromLet a) (LetFloatFromLet b) = a `compare` b
cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
\begin{code}
getSwitchChecker :: SimplM SwitchChecker
-getSwitchChecker env us sc = (seChkr env, us, sc)
+getSwitchChecker dflags env us sc = (seChkr env, us, sc)
getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int
getSimplIntSwitch chkr switch
\begin{code}
setBlackList :: BlackList -> SimplM a -> SimplM a
-setBlackList black_list m env us sc = m (env { seBlackList = black_list }) us sc
+setBlackList black_list m dflags env us sc
+ = m dflags (env { seBlackList = black_list }) us sc
getBlackList :: SimplM BlackList
-getBlackList env us sc = (seBlackList env, us, sc)
+getBlackList dflags env us sc = (seBlackList env, us, sc)
-noInlineBlackList :: BlackList
+noInlineBlackList :: SimplM BlackList
-- Inside inlinings, black list anything that is in scope or imported.
-- except for things that must be unfolded (Compulsory)
-- and data con wrappers. The latter is a hack, like the one in
-- SimplCore.simplRules, to make wrappers inline in rule LHSs.
-- We may as well do the same here.
-noInlineBlackList v = not (isCompulsoryUnfolding (idUnfolding v)) &&
- not (isDataConWrapId v)
- -- NB: this implementation means that even inlinings *completely within*
- -- an INLINE won't happen, which is perhaps overkill.
- -- An earlier verion had: (v `isInScope` subst) || not (isLocallyDefined v)
- -- but it's more expensive, and it probably doesn't matter.
+noInlineBlackList dflags env us sc = (blacklisted,us,sc)
+ where blacklisted v =
+ not (isCompulsoryUnfolding (idUnfolding v)) &&
+ not (isDataConWrapId v) &&
+ (v `isInScope` (seSubst env) || isGlobalId v)
+ -- NB: An earlier version omitted the last clause; this meant
+ -- that even inlinings *completely within* an INLINE didn't happen.
+ -- This was cheaper, and probably adequate, but produced awful code
+ -- for some dictionary constructions.
\end{code}
\begin{code}
getEnclosingCC :: SimplM CostCentreStack
-getEnclosingCC env us sc = (seCC env, us, sc)
+getEnclosingCC dflags env us sc = (seCC env, us, sc)
setEnclosingCC :: CostCentreStack -> SimplM a -> SimplM a
-setEnclosingCC cc m env us sc = m (env { seCC = cc }) us sc
+setEnclosingCC cc m dflags env us sc = m dflags (env { seCC = cc }) us sc
\end{code}
-- The top level "enclosing CC" is "SUBSUMED".
getEnv :: SimplM SimplEnv
-getEnv env us sc = (env, us, sc)
+getEnv dflags env us sc = (env, us, sc)
setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
-setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m
+setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m dflags
(SimplEnv {seSubst = old_subst}) us sc
- = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
+ = m dflags (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)})
+ us sc
getSubst :: SimplM Subst
-getSubst env us sc = (seSubst env, us, sc)
+getSubst dflags env us sc = (seSubst env, us, sc)
setSubst :: Subst -> SimplM a -> SimplM a
-setSubst subst m env us sc = m (env {seSubst = subst}) us sc
+setSubst subst m dflags env us sc = m dflags (env {seSubst = subst}) us sc
getSubstEnv :: SimplM SubstEnv
-getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
+getSubstEnv dflags env us sc = (substEnv (seSubst env), us, sc)
addNewInScopeIds :: [CoreBndr] -> SimplM a -> SimplM a
-- The new Ids are guaranteed to be freshly allocated
-addNewInScopeIds vs m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
+addNewInScopeIds vs m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.extendNewInScopeList subst vs}) us sc
getInScope :: SimplM InScopeSet
-getInScope env us sc = (substInScope (seSubst env), us, sc)
+getInScope dflags env us sc = (substInScope (seSubst env), us, sc)
setInScope :: InScopeSet -> SimplM a -> SimplM a
-setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.setInScope subst in_scope}) us sc
+setInScope in_scope m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.setInScope subst in_scope}) us sc
modifyInScope :: CoreBndr -> CoreBndr -> SimplM a -> SimplM a
-modifyInScope v v' m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.modifyInScope subst v v'}) us sc
+modifyInScope v v' m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.modifyInScope subst v v'}) us sc
extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
-extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
- = m (env { seSubst = Subst.extendSubst subst var res }) us sc
+extendSubst var res m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env { seSubst = Subst.extendSubst subst var res }) us sc
extendSubstList :: [CoreBndr] -> [SubstResult] -> SimplM a -> SimplM a
-extendSubstList vars ress m env@(SimplEnv {seSubst = subst}) us sc
- = m (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
+extendSubstList vars ress m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env { seSubst = Subst.extendSubstList subst vars ress }) us sc
setSubstEnv :: SubstEnv -> SimplM a -> SimplM a
-setSubstEnv senv m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.setSubstEnv subst senv}) us sc
+setSubstEnv senv m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.setSubstEnv subst senv}) us sc
zapSubstEnv :: SimplM a -> SimplM a
-zapSubstEnv m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.zapSubstEnv subst}) us sc
+zapSubstEnv m dflags env@(SimplEnv {seSubst = subst}) us sc
+ = m dflags (env {seSubst = Subst.zapSubstEnv subst}) us sc
getSimplBinderStuff :: SimplM (Subst, UniqSupply)
-getSimplBinderStuff (SimplEnv {seSubst = subst}) us sc
+getSimplBinderStuff dflags (SimplEnv {seSubst = subst}) us sc
= ((subst, us), us, sc)
setSimplBinderStuff :: (Subst, UniqSupply) -> SimplM a -> SimplM a
-setSimplBinderStuff (subst, us) m env _ sc
- = m (env {seSubst = subst}) us sc
+setSimplBinderStuff (subst, us) m dflags env _ sc
+ = m dflags (env {seSubst = subst}) us sc
\end{code}
\begin{code}
newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
-- Extends the in-scope-env too
-newId fs ty m env@(SimplEnv {seSubst = subst}) us sc
+newId fs ty m dflags env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m v (env {seSubst = Subst.extendNewInScope subst v}) us2 sc
+ (us1, us2) -> m v dflags (env {seSubst = Subst.extendNewInScope subst v})
+ us2 sc
where
v = mkSysLocal fs (uniqFromSupply us1) ty
newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
-newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc
+newIds fs tys m dflags env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m vs (env {seSubst = Subst.extendNewInScopeList subst vs}) us2 sc
+ (us1, us2) -> m vs dflags (env {seSubst = Subst.extendNewInScopeList subst vs})
+ us2 sc
where
- vs = zipWithEqual "newIds" (mkSysLocal fs)
- (uniqsFromSupply (length tys) us1) tys
+ vs = zipWith (mkSysLocal fs) (uniqsFromSupply us1) tys
\end{code}
projects / ghc-hetmet.git / blobdiff