OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
OutExprStuff, OutStuff,
- -- The continuation type
- SimplCont(..), DupFlag(..), contIsDupable, contResultType,
- contIsInteresting, pushArgs, discardCont, countValArgs, countArgs,
- contArgs, contIsInline, discardInline,
-
-- The monad
SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl,
-- The inlining black-list
- getBlackList,
+ setBlackList, getBlackList, noInlineBlackList,
-- Unique supply
getUniqueSmpl, getUniquesSmpl,
getEnclosingCC, setEnclosingCC,
-- Environments
+ getEnv, setAllExceptInScope,
getSubst, setSubst,
getSubstEnv, extendSubst, extendSubstList,
- getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
+ getInScope, setInScope, modifyInScope, addNewInScopeIds,
setSubstEnv, zapSubstEnv,
getSimplBinderStuff, setSimplBinderStuff,
- switchOffInlining
+
+ -- Adding bindings
+ addLetBind, addLetBinds, addAuxiliaryBind, addAuxiliaryBinds,
+ addCaseBind, needsCaseBinding, addNonRecBind
) where
#include "HsVersions.h"
-import Const ( Con(DEFAULT) )
-import Id ( Id, mkSysLocal, idMustBeINLINEd )
-import IdInfo ( InlinePragInfo(..) )
-import Demand ( Demand )
+import Id ( Id, mkSysLocal, idType, idUnfolding, isDataConWrapId )
import CoreSyn
+import CoreUnfold ( isCompulsoryUnfolding )
+import CoreUtils ( exprOkForSpeculation )
import PprCore () -- Instances
-import Rules ( RuleBase )
import CostCentre ( CostCentreStack, subsumedCCS )
-import Var ( TyVar )
+import Name ( isLocallyDefined )
+import OccName ( UserFS )
import VarEnv
import VarSet
import qualified Subst
-import Subst ( Subst, emptySubst, mkSubst,
- substTy, substEnv, substExpr,
- InScopeSet, substInScope, isInScope, lookupInScope
+import Subst ( Subst, mkSubst, substEnv,
+ InScopeSet, mkInScopeSet, substInScope, isInScope
)
-import Type ( Type, TyVarSubst, applyTy )
+import Type ( Type, isUnLiftedType )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
UniqSupply
)
import FiniteMap
import CmdLineOpts ( SimplifierSwitch(..), SwitchResult(..),
- opt_PprStyle_Debug, opt_HistorySize,
+ opt_PprStyle_Debug, opt_HistorySize, opt_D_dump_simpl_stats,
intSwitchSet
)
import Unique ( Unique )
import Util ( zipWithEqual )
import Outputable
-infixr 9 `thenSmpl`, `thenSmpl_`
+infixr 0 `thenSmpl`, `thenSmpl_`
\end{code}
%************************************************************************
type OutArg = CoreArg
type SwitchChecker = SimplifierSwitch -> SwitchResult
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The continuation data type}
-%* *
-%************************************************************************
-
-\begin{code}
type OutExprStuff = OutStuff (InScopeSet, OutExpr)
type OutStuff a = ([OutBind], 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
-
-data SimplCont -- Strict contexts
- = Stop OutType -- Type of the result
-
- | CoerceIt OutType -- The To-type, simplified
- SimplCont
-
- | InlinePlease -- This continuation makes a function very
- SimplCont -- keen to inline itelf
-
- | ApplyTo DupFlag
- InExpr SubstEnv -- The argument, as yet unsimplified,
- SimplCont -- and its subst-env
-
- | Select DupFlag
- InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
- SimplCont
-
- | ArgOf DupFlag -- An arbitrary strict context: the argument
- -- of a strict function, or a primitive-arg fn
- -- or a PrimOp
- OutType -- The type of the expression being sought by the context
- -- f (error "foo") ==> coerce t (error "foo")
- -- when f is strict
- -- We need to know the type t, to which to coerce.
- (OutExpr -> SimplM OutExprStuff) -- What to do with the result
-
-instance Outputable SimplCont where
- ppr (Stop _) = ptext SLIT("Stop")
- ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
- ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
- ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
- (nest 4 (ppr alts)) $$ ppr cont
- ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
- ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
-
-data DupFlag = OkToDup | NoDup
-
-instance Outputable DupFlag where
- ppr OkToDup = ptext SLIT("ok")
- ppr NoDup = ptext SLIT("nodup")
-
-contIsDupable :: SimplCont -> Bool
-contIsDupable (Stop _) = True
-contIsDupable (ApplyTo OkToDup _ _ _) = True
-contIsDupable (ArgOf OkToDup _ _) = True
-contIsDupable (Select OkToDup _ _ _ _) = True
-contIsDupable (CoerceIt _ cont) = contIsDupable cont
-contIsDupable (InlinePlease cont) = contIsDupable cont
-contIsDupable other = False
-
-contArgs :: InScopeSet -> SimplCont -> ([OutExpr], SimplCont)
- -- Get the arguments from the continuation
- -- Apply the appropriate substitution first;
- -- this is done lazily and typically only the bit at the top is used
-contArgs in_scope (ApplyTo _ e s cont)
- = case contArgs in_scope cont of
- (args, result) -> (substExpr (mkSubst in_scope s) e : args, result)
-contArgs in_scope result_cont
- = ([], result_cont)
-
-contIsInline :: SimplCont -> Bool
-contIsInline (InlinePlease cont) = True
-contIsInline other = False
-
-discardInline :: SimplCont -> SimplCont
-discardInline (InlinePlease cont) = cont
-discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
-discardInline cont = cont
-\end{code}
-
-
-Comment about contIsInteresting
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to avoid inlining an expression where there can't possibly be
-any gain, such as in an argument position. Hence, if the continuation
-is interesting (eg. a case scrutinee, application etc.) then we
-inline, otherwise we don't.
-
-Previously some_benefit used to return True only if the variable was
-applied to some value arguments. This didn't work:
-
- let x = _coerce_ (T Int) Int (I# 3) in
- case _coerce_ Int (T Int) x of
- I# y -> ....
-
-we want to inline x, but can't see that it's a constructor in a case
-scrutinee position, and some_benefit is False.
-
-Another example:
-
-dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
-
-.... case dMonadST _@_ x0 of (a,b,c) -> ....
-
-we'd really like to inline dMonadST here, but we *don't* want to
-inline if the case expression is just
-
- case x of y { DEFAULT -> ... }
-
-since we can just eliminate this case instead (x is in WHNF). Similar
-applies when x is bound to a lambda expression. Hence
-contIsInteresting looks for case expressions with just a single
-default case.
-
-\begin{code}
-contIsInteresting :: SimplCont -> Bool
-contIsInteresting (Select _ _ alts _ _) = not (just_default alts)
-contIsInteresting (CoerceIt _ cont) = contIsInteresting cont
-contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
-contIsInteresting (ApplyTo _ _ _ _) = True
-
-contIsInteresting (ArgOf _ _ _) = False
- -- If this call is the arg of a strict function, the context
- -- is a bit interesting. If we inline here, we may get useful
- -- evaluation information to avoid repeated evals: e.g.
- -- x + (y * z)
- -- Here the contIsInteresting makes the '*' keener to inline,
- -- which in turn exposes a constructor which makes the '+' inline.
- -- Assuming that +,* aren't small enough to inline regardless.
- --
- -- HOWEVER, I put this back to False when I discovered that strings
- -- were getting inlined straight back into applications of 'error'
- -- because the latter is strict.
- -- s = "foo"
- -- f = \x -> ...(error s)...
-
-contIsInteresting (InlinePlease _) = True
-contIsInteresting other = False
-
-just_default [(DEFAULT,_,_)] = True -- See notes below for why we look
-just_default alts = False -- for this special case
\end{code}
-
\begin{code}
-pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
-pushArgs se [] cont = cont
-pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
-
-discardCont :: SimplCont -- A continuation, expecting
- -> SimplCont -- Replace the continuation with a suitable coerce
-discardCont (Stop to_ty) = Stop to_ty
-discardCont cont = CoerceIt to_ty (Stop to_ty)
- where
- to_ty = contResultType cont
-
-contResultType :: SimplCont -> OutType
-contResultType (Stop to_ty) = to_ty
-contResultType (ArgOf _ to_ty _) = to_ty
-contResultType (ApplyTo _ _ _ cont) = contResultType cont
-contResultType (CoerceIt _ cont) = contResultType cont
-contResultType (InlinePlease cont) = contResultType cont
-contResultType (Select _ _ _ _ cont) = contResultType cont
-
-countValArgs :: SimplCont -> Int
-countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
-countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
-countValArgs other = 0
-
-countArgs :: SimplCont -> Int
-countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
-countArgs other = 0
+addLetBind :: CoreBind -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+addLetBind bind thing_inside
+ = thing_inside `thenSmpl` \ (binds, res) ->
+ returnSmpl (bind : binds, res)
+
+addLetBinds :: [CoreBind] -> SimplM (OutStuff a) -> SimplM (OutStuff a)
+addLetBinds binds1 thing_inside
+ = thing_inside `thenSmpl` \ (binds2, res) ->
+ returnSmpl (binds1 ++ 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
+ = getInScope `thenSmpl` \ in_scope ->
+ thing_inside `thenSmpl` \ (floats, (_, body)) ->
+ returnSmpl ([], (in_scope, Case rhs bndr [(DEFAULT, [], mkLets 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}
-> SimplCount
-> (result, UniqSupply, SimplCount)
+type BlackList = Id -> Bool -- True => don't inline this Id
+
data SimplEnv
= SimplEnv {
seChkr :: SwitchChecker,
seCC :: CostCentreStack, -- The enclosing CCS (when profiling)
- seBlackList :: Id -> Bool, -- True => don't inline this Id
+ seBlackList :: BlackList,
seSubst :: Subst -- The current substitution
}
-- The range of the substitution is OutType and OutExpr resp
initSmpl :: SwitchChecker
-> UniqSupply -- No init count; set to 0
-> VarSet -- In scope (usually empty, but useful for nested calls)
- -> (Id -> Bool) -- Black-list function
+ -> BlackList -- Black-list function
-> SimplM a
-> (a, SimplCount)
\begin{code}
verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
--- Defined both with and without debugging
zeroSimplCount :: SimplCount
isZeroSimplCount :: SimplCount -> Bool
pprSimplCount :: SimplCount -> SDoc
\end{code}
\begin{code}
-#ifndef DEBUG
-----------------------------------------------------------
--- Debugging OFF
-----------------------------------------------------------
-type SimplCount = Int
-
-zeroSimplCount = 0
-
-isZeroSimplCount n = n==0
+data SimplCount = VerySimplZero -- These two are used when
+ | VerySimplNonZero -- we are only interested in
+ -- termination info
-doTick t n = n+1 -- Very basic when not debugging
-doFreeTick t n = n -- Don't count leaf visits
-
-pprSimplCount n = ptext SLIT("Total ticks:") <+> int n
-
-plusSimplCount n m = n+m
-
-#else
-----------------------------------------------------------
--- Debugging ON
-----------------------------------------------------------
-
-data SimplCount = SimplCount {
+ | SimplCount {
ticks :: !Int, -- Total ticks
details :: !TickCounts, -- How many of each type
n_log :: !Int, -- N
type TickCounts = FiniteMap Tick Int
-zeroSimplCount = SimplCount {ticks = 0, details = emptyFM,
- n_log = 0, log1 = [], log2 = []}
+zeroSimplCount -- 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
-isZeroSimplCount sc = ticks sc == 0
+isZeroSimplCount VerySimplZero = True
+isZeroSimplCount (SimplCount { ticks = 0 }) = True
+isZeroSimplCount other = False
doFreeTick tick sc@SimplCount { details = dts }
= dts' `seqFM` sc { details = dts' }
where
dts' = dts `addTick` tick
+doFreeTick tick sc = sc
-- Gross hack to persuade GHC 3.03 to do this important seq
seqFM fm x | isEmptyFM fm = x
where
sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
+doTick tick sc = VerySimplNonZero -- The very simple case
+
+
-- Don't use plusFM_C because that's lazy, and we want to
-- be pretty strict here!
addTick :: TickCounts -> Tick -> TickCounts
where
n1 = n+1
+
plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
sc2@(SimplCount { ticks = tks2, details = dts2 })
= log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
| null (log2 sc2) = sc2 { log2 = log1 sc1 }
| otherwise = sc2
+plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
+plusSimplCount sc1 sc2 = VerySimplNonZero
+pprSimplCount VerySimplZero = ptext SLIT("Total ticks: ZERO!")
+pprSimplCount VerySimplNonZero = ptext SLIT("Total ticks: NON-ZERO!")
pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
= vcat [ptext SLIT("Total ticks: ") <+> int tks,
text "",
= nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
| otherwise
= empty
-#endif
\end{code}
%************************************************************************
| FillInCaseDefault Id -- Case binder
| BottomFound
- | LeafVisit
| SimplifierDone -- Ticked at each iteration of the simplifier
isRuleFired (RuleFired _) = True
tickToTag (CaseIdentity _) = 12
tickToTag (FillInCaseDefault _) = 13
tickToTag BottomFound = 14
-tickToTag LeafVisit = 15
tickToTag SimplifierDone = 16
tickString :: Tick -> String
tickString (FillInCaseDefault _) = "FillInCaseDefault"
tickString BottomFound = "BottomFound"
tickString SimplifierDone = "SimplifierDone"
-tickString LeafVisit = "LeafVisit"
pprTickCts :: Tick -> SDoc
pprTickCts (PreInlineUnconditionally v) = ppr v
\end{code}
-@switchOffInlining@ is used to prepare the environment for simplifying
+@setBlackList@ is used to prepare the environment for simplifying
the RHS of an Id that's marked with an INLINE pragma. It is going to
be inlined wherever they are used, and then all the inlining will take
effect. Meanwhile, there isn't much point in doing anything to the
then we won't get deforestation at all.
We havn't solved this problem yet!
-We prepare the envt by simply modifying the in_scope_env, which has all the
-unfolding info. At one point we did it by modifying the chkr so that
-it said "EssentialUnfoldingsOnly", but that prevented legitmate, and
-important, simplifications happening in the body of the RHS.
+We prepare the envt by simply modifying the black list.
6/98 update:
selector, so failing to inline it in the RHS of `f' will
leave a reference to a non-existent id, with bad consequences.
-ALSO NOTE that we do all this by modifing the inline-pragma,
+ALSO NOTE that we do all this by modifing the black list
not by zapping the unfolding. The latter may still be useful for
knowing when something is evaluated.
-June 98 update: I've gone back to dealing with this by adding
-the EssentialUnfoldingsOnly switch. That doesn't stop essential
-unfoldings, nor inlineUnconditionally stuff; and the thing's going
-to be inlined at every call site anyway. Running over the whole
-environment seems like wild overkill.
-
\begin{code}
-switchOffInlining :: SimplM a -> SimplM a
-switchOffInlining m env us sc
- = m (env { seBlackList = \v -> True }) us sc
+setBlackList :: BlackList -> SimplM a -> SimplM a
+setBlackList black_list m env us sc = m (env { seBlackList = black_list }) us sc
+
+getBlackList :: SimplM BlackList
+getBlackList env us sc = (seBlackList env, us, sc)
+
+noInlineBlackList :: 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.
\end{code}
\begin{code}
-emptySimplEnv :: SwitchChecker -> InScopeSet -> (Id -> Bool) -> SimplEnv
+emptySimplEnv :: SwitchChecker -> VarSet -> (Id -> Bool) -> SimplEnv
emptySimplEnv sw_chkr in_scope black_list
= SimplEnv { seChkr = sw_chkr, seCC = subsumedCCS,
seBlackList = black_list,
- seSubst = mkSubst in_scope emptySubstEnv }
+ seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv }
-- The top level "enclosing CC" is "SUBSUMED".
+getEnv :: SimplM SimplEnv
+getEnv env us sc = (env, us, sc)
+
+setAllExceptInScope :: SimplEnv -> SimplM a -> SimplM a
+setAllExceptInScope new_env@(SimplEnv {seSubst = new_subst}) m
+ (SimplEnv {seSubst = old_subst}) us sc
+ = m (new_env {seSubst = Subst.setInScope new_subst (substInScope old_subst)}) us sc
+
getSubst :: SimplM Subst
getSubst env us sc = (seSubst env, us, sc)
-getBlackList :: SimplM (Id -> Bool)
-getBlackList env us sc = (seBlackList env, us, sc)
-
setSubst :: Subst -> SimplM a -> SimplM a
setSubst subst m env us sc = m (env {seSubst = subst}) us sc
getSubstEnv :: SimplM SubstEnv
getSubstEnv env us sc = (substEnv (seSubst env), us, sc)
-extendInScope :: CoreBndr -> SimplM a -> SimplM a
-extendInScope v m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.extendInScope subst v}) us sc
-
-extendInScopes :: [CoreBndr] -> SimplM a -> SimplM a
-extendInScopes vs m env@(SimplEnv {seSubst = subst}) us sc
- = m (env {seSubst = Subst.extendInScopes subst vs}) 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
getInScope :: SimplM InScopeSet
getInScope env us sc = (substInScope (seSubst env), us, sc)
setInScope in_scope m env@(SimplEnv {seSubst = subst}) us sc
= m (env {seSubst = Subst.setInScope subst in_scope}) us sc
-modifyInScope :: CoreBndr -> SimplM a -> SimplM a
-modifyInScope v m env us sc
-#ifdef DEBUG
- | not (v `isInScope` seSubst env)
- = pprTrace "modifyInScope: not in scope:" (ppr v)
- m env us sc
-#endif
- | otherwise
- = extendInScope v m env 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
extendSubst :: CoreBndr -> SubstResult -> SimplM a -> SimplM a
extendSubst var res m env@(SimplEnv {seSubst = subst}) us sc
\begin{code}
-newId :: Type -> (Id -> SimplM a) -> SimplM a
+newId :: UserFS -> Type -> (Id -> SimplM a) -> SimplM a
-- Extends the in-scope-env too
-newId ty m env@(SimplEnv {seSubst = subst}) us sc
+newId fs ty m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m v (env {seSubst = Subst.extendInScope subst v}) us2 sc
+ (us1, us2) -> m v (env {seSubst = Subst.extendNewInScope subst v}) us2 sc
where
- v = mkSysLocal SLIT("s") (uniqFromSupply us1) ty
+ v = mkSysLocal fs (uniqFromSupply us1) ty
-newIds :: [Type] -> ([Id] -> SimplM a) -> SimplM a
-newIds tys m env@(SimplEnv {seSubst = subst}) us sc
+newIds :: UserFS -> [Type] -> ([Id] -> SimplM a) -> SimplM a
+newIds fs tys m env@(SimplEnv {seSubst = subst}) us sc
= case splitUniqSupply us of
- (us1, us2) -> m vs (env {seSubst = Subst.extendInScopes subst vs}) us2 sc
+ (us1, us2) -> m vs (env {seSubst = Subst.extendNewInScopeList subst vs}) us2 sc
where
- vs = zipWithEqual "newIds" (mkSysLocal SLIT("s"))
+ vs = zipWithEqual "newIds" (mkSysLocal fs)
(uniqsFromSupply (length tys) us1) tys
-
\end{code}
projects / ghc-hetmet.git / blobdiff