OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder,
OutExprStuff, OutStuff,
- -- The continuation type
- SimplCont(..), DupFlag(..), contIsDupable, contResultType,
- contIsInteresting, pushArgs, discardCont, countValArgs, countArgs,
- contIsInline, discardInlineCont,
-
-- The monad
SimplM,
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
getEnclosingCC, setEnclosingCC,
-- Environments
+ getEnv, setAllExceptInScope,
getSubst, setSubst,
getSubstEnv, extendSubst, extendSubstList,
getInScope, setInScope, extendInScope, extendInScopes, modifyInScope,
#include "HsVersions.h"
-import Const ( Con(DEFAULT) )
-import Id ( Id, mkSysLocal, idMustBeINLINEd )
+import Id ( Id, mkSysLocal, idUnfolding, isDataConWrapId )
import IdInfo ( InlinePragInfo(..) )
import Demand ( Demand )
import CoreSyn
+import CoreUnfold ( isCompulsoryUnfolding, isEvaldUnfolding )
import PprCore () -- Instances
import Rules ( RuleBase )
import CostCentre ( CostCentreStack, subsumedCCS )
+import Name ( isLocallyDefined )
import Var ( TyVar )
import VarEnv
import VarSet
import qualified Subst
-import Subst ( Subst, emptySubst, mkSubst,
- substTy, substEnv,
- InScopeSet, substInScope, isInScope, lookupInScope
+import Subst ( Subst, emptySubst, mkSubst,
+ substTy, substEnv,
+ InScopeSet, substInScope, isInScope
)
import Type ( Type, TyVarSubst, applyTy )
import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply,
)
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
-
-contIsInline :: SimplCont -> Bool
-contIsInline (InlinePlease cont) = True
-contIsInline other = False
-
-discardInlineCont :: SimplCont -> SimplCont
-discardInlineCont (InlinePlease cont) = cont
-discardInlineCont 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 _ _ _) = True
- -- 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.
-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
\end{code}
\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
-
-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
+data SimplCount = VerySimplZero -- These two are used when
+ | VerySimplNonZero -- we are only interested in
+ -- termination info
-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
\begin{code}
switchOffInlining :: SimplM a -> SimplM a
switchOffInlining m env us sc
- = m (env { seBlackList = \v -> True }) us sc
+ = m (env { seBlackList = \v -> not (isCompulsoryUnfolding (idUnfolding v)) &&
+ not (isDataConWrapId v) &&
+ ((v `isInScope` subst) || not (isLocallyDefined v))
+ }) us sc
+
+ -- 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.
+ where
+ subst = seSubst env
+ old_black_list = seBlackList env
\end{code}
seSubst = mkSubst 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)
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
projects / ghc-hetmet.git / blobdiff