X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplMonad.lhs;h=bc09e1128ce96c8dbc97fa159b21b3e52e003aa8;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=09c8916e5a195b51cd59245d331c20d949f01037;hpb=aef84dceb73aae423df4fd28d9852a200f55b0ce;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 09c8916..bc09e11 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -5,21 +5,14 @@ \begin{code} module SimplMonad ( - InId, InBind, InExpr, InAlt, InArg, InType, InBinder, - OutId, OutTyVar, OutBind, OutExpr, OutAlt, OutArg, OutType, OutBinder, - FloatsWith, FloatsWithExpr, - -- The monad SimplM, initSmpl, returnSmpl, thenSmpl, thenSmpl_, mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl, getDOptsSmpl, - -- The simplifier mode - setMode, getMode, - -- Unique supply - getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, + getUniqueSmpl, getUniquesSmpl, getUniqSupplySmpl, newId, -- Counting SimplCount, Tick(..), @@ -28,62 +21,25 @@ module SimplMonad ( plusSimplCount, isZeroSimplCount, -- Switch checker - SwitchChecker, SwitchResult(..), getSwitchChecker, getSimplIntSwitch, - isAmongSimpl, intSwitchSet, switchIsOn, - - -- Cost centres - getEnclosingCC, setEnclosingCC, - - -- Environments - SimplEnv, emptySimplEnv, getSubst, setSubst, - getSubstEnv, extendSubst, extendSubstList, - getInScope, setInScope, modifyInScope, addNewInScopeIds, - setSubstEnv, zapSubstEnv, - - -- Floats - Floats, emptyFloats, isEmptyFloats, unitFloat, addFloats, flattenFloats, - allLifted, wrapFloats, floatBinds, - addAuxiliaryBind, - - -- Inlining, - preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule, - inlineMode + SwitchChecker, SwitchResult(..), getSimplIntSwitch, + isAmongSimpl, intSwitchSet, switchIsOn ) where #include "HsVersions.h" -import Id ( Id, idType, idOccInfo, idInlinePragma ) -import CoreSyn -import CoreUtils ( needsCaseBinding, exprIsTrivial ) -import PprCore () -- Instances -import CostCentre ( CostCentreStack, subsumedCCS ) -import Var -import VarEnv -import VarSet -import OrdList -import qualified Subst -import Subst ( Subst, mkSubst, substEnv, - InScopeSet, mkInScopeSet, substInScope, - isInScope - ) -import Type ( Type, isUnLiftedType ) +import Id ( Id, mkSysLocal ) +import Type ( Type ) import UniqSupply ( uniqsFromSupply, uniqFromSupply, splitUniqSupply, UniqSupply ) -import FiniteMap -import BasicTypes ( TopLevelFlag, isTopLevel, isLoopBreaker, - Activation, isActive, isAlwaysActive, - OccInfo(..), isOneOcc - ) -import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), - DynFlags, DynFlag(..), dopt, - opt_PprStyle_Debug, opt_HistorySize, opt_SimplNoPreInlining, - ) +import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt ) +import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize ) import Unique ( Unique ) +import Maybes ( expectJust ) +import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addToFM, plusFM_C, fmToList ) +import FastString ( FastString ) import Outputable import FastTypes -import FastString -import Maybes ( expectJust ) import GLAEXTS ( indexArray# ) @@ -100,108 +56,6 @@ infixr 0 `thenSmpl`, `thenSmpl_` %************************************************************************ %* * -\subsection[Simplify-types]{Type declarations} -%* * -%************************************************************************ - -\begin{code} -type InBinder = CoreBndr -type InId = Id -- Not yet cloned -type InType = Type -- Ditto -type InBind = CoreBind -type InExpr = CoreExpr -type InAlt = CoreAlt -type InArg = CoreArg - -type OutBinder = CoreBndr -type OutId = Id -- Cloned -type OutTyVar = TyVar -- Cloned -type OutType = Type -- Cloned -type OutBind = CoreBind -type OutExpr = CoreExpr -type OutAlt = CoreAlt -type OutArg = CoreArg -\end{code} - -%************************************************************************ -%* * -\subsection{Floats} -%* * -%************************************************************************ - -\begin{code} -type FloatsWithExpr = FloatsWith OutExpr -type FloatsWith a = (Floats, 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 Floats = Floats (OrdList OutBind) - InScopeSet -- Environment "inside" all the floats - Bool -- True <=> All bindings are lifted - -allLifted :: Floats -> Bool -allLifted (Floats _ _ is_lifted) = is_lifted - -wrapFloats :: Floats -> OutExpr -> OutExpr -wrapFloats (Floats bs _ _) body = foldrOL Let body bs - -isEmptyFloats :: Floats -> Bool -isEmptyFloats (Floats bs _ _) = isNilOL bs - -floatBinds :: Floats -> [OutBind] -floatBinds (Floats bs _ _) = fromOL bs - -flattenFloats :: Floats -> Floats --- Flattens into a single Rec group -flattenFloats (Floats bs is is_lifted) - = ASSERT2( is_lifted, ppr (fromOL bs) ) - Floats (unitOL (Rec (flattenBinds (fromOL bs)))) is is_lifted -\end{code} - -\begin{code} -emptyFloats :: SimplEnv -> Floats -emptyFloats env = Floats nilOL (getInScope env) True - -unitFloat :: SimplEnv -> OutId -> OutExpr -> Floats --- A single non-rec float; extend the in-scope set -unitFloat env var rhs = Floats (unitOL (NonRec var rhs)) - (Subst.extendInScopeSet (getInScope env) var) - (not (isUnLiftedType (idType var))) - -addFloats :: SimplEnv -> Floats - -> (SimplEnv -> SimplM (FloatsWith a)) - -> SimplM (FloatsWith a) -addFloats env (Floats b1 is1 l1) thing_inside - | isNilOL b1 - = thing_inside env - | otherwise - = thing_inside (setInScopeSet env is1) `thenSmpl` \ (Floats b2 is2 l2, res) -> - returnSmpl (Floats (b1 `appOL` b2) is2 (l1 && l2), res) - -addLetBind :: OutBind -> Floats -> Floats -addLetBind bind (Floats binds in_scope lifted) - = Floats (bind `consOL` binds) in_scope (lifted && is_lifted_bind bind) - -is_lifted_bind (Rec _) = True -is_lifted_bind (NonRec b r) = not (isUnLiftedType (idType b)) - --- addAuxiliaryBind * takes already-simplified things (bndr and rhs) --- * extends the in-scope env --- * assumes it's a let-bindable thing -addAuxiliaryBind :: SimplEnv -> OutBind - -> (SimplEnv -> SimplM (FloatsWith a)) - -> SimplM (FloatsWith a) - -- Extends the in-scope environment as well as wrapping the bindings -addAuxiliaryBind env bind thing_inside - = ASSERT( case bind of { NonRec b r -> not (needsCaseBinding (idType b) r) ; Rec _ -> True } ) - thing_inside (addNewInScopeIds env (bindersOf bind)) `thenSmpl` \ (floats, x) -> - returnSmpl (addLetBind bind floats, x) -\end{code} - - -%************************************************************************ -%* * \subsection{Monad plumbing} %* * %************************************************************************ @@ -210,11 +64,11 @@ For the simplifier monad, we want to {\em thread} a unique supply and a counter. (Command-line switches move around through the explicitly-passed SimplEnv.) \begin{code} -type SimplM result - = DynFlags -- We thread the unique supply because - -> UniqSupply -- constantly splitting it is rather expensive - -> SimplCount - -> (result, UniqSupply, SimplCount) +newtype SimplM result + = SM { unSM :: DynFlags -- We thread the unique supply because + -> UniqSupply -- constantly splitting it is rather expensive + -> SimplCount + -> (result, UniqSupply, SimplCount)} \end{code} \begin{code} @@ -224,7 +78,7 @@ initSmpl :: DynFlags -> (a, SimplCount) initSmpl dflags us m - = case m dflags us (zeroSimplCount dflags) of + = case unSM m dflags us (zeroSimplCount dflags) of (result, _, count) -> (result, count) @@ -232,19 +86,26 @@ initSmpl dflags us m {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-} +instance Monad SimplM where + (>>) = thenSmpl_ + (>>=) = thenSmpl + return = returnSmpl + returnSmpl :: a -> SimplM a -returnSmpl e dflags us sc = (e, us, sc) +returnSmpl e = SM (\ dflags us sc -> (e, us, sc)) thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b thenSmpl_ :: SimplM a -> SimplM b -> SimplM b -thenSmpl m k dflags us0 sc0 - = case (m dflags us0 sc0) of - (m_result, us1, sc1) -> k m_result dflags us1 sc1 +thenSmpl m k + = SM (\ dflags us0 sc0 -> + case (unSM m dflags us0 sc0) of + (m_result, us1, sc1) -> unSM (k m_result) dflags us1 sc1 ) -thenSmpl_ m k dflags us0 sc0 - = case (m dflags us0 sc0) of - (_, us1, sc1) -> k dflags us1 sc1 +thenSmpl_ m k + = SM (\dflags us0 sc0 -> + case (unSM m dflags us0 sc0) of + (_, us1, sc1) -> unSM k dflags us1 sc1) \end{code} @@ -264,6 +125,7 @@ mapAndUnzipSmpl f (x:xs) mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) -> returnSmpl (r1:rs1, r2:rs2) +mapAccumLSmpl :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) mapAccumLSmpl f acc [] = returnSmpl (acc, []) mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') -> @@ -279,23 +141,27 @@ mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> \begin{code} getUniqSupplySmpl :: SimplM UniqSupply -getUniqSupplySmpl dflags us sc - = case splitUniqSupply us of - (us1, us2) -> (us1, us2, sc) +getUniqSupplySmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (us1, us2, sc)) getUniqueSmpl :: SimplM Unique -getUniqueSmpl dflags us sc - = case splitUniqSupply us of - (us1, us2) -> (uniqFromSupply us1, us2, sc) +getUniqueSmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (uniqFromSupply us1, us2, sc)) getUniquesSmpl :: SimplM [Unique] -getUniquesSmpl dflags us sc - = case splitUniqSupply us of - (us1, us2) -> (uniqsFromSupply us1, us2, sc) +getUniquesSmpl + = SM (\dflags us sc -> case splitUniqSupply us of + (us1, us2) -> (uniqsFromSupply us1, us2, sc)) getDOptsSmpl :: SimplM DynFlags -getDOptsSmpl dflags us sc - = (dflags, us, sc) +getDOptsSmpl + = SM (\dflags us sc -> (dflags, us, sc)) + +newId :: FastString -> Type -> SimplM Id +newId fs ty = getUniqueSmpl `thenSmpl` \ uniq -> + returnSmpl (mkSysLocal fs uniq ty) \end{code} @@ -307,21 +173,19 @@ getDOptsSmpl dflags us sc \begin{code} getSimplCount :: SimplM SimplCount -getSimplCount dflags us sc = (sc, us, sc) +getSimplCount = SM (\dflags us sc -> (sc, us, sc)) tick :: Tick -> SimplM () -tick t dflags us sc - = sc' `seq` ((), us, sc') - where - sc' = doTick t sc +tick t + = SM (\dflags us sc -> let sc' = doTick t sc + in sc' `seq` ((), us, 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 dflags us sc - = sc' `seq` ((), us, sc') - where - sc' = doFreeTick t sc +freeTick t + = SM (\dflags us sc -> let sc' = doFreeTick t sc + in sc' `seq` ((), us, sc')) \end{code} \begin{code} @@ -564,379 +428,6 @@ cmpEqTick other1 other2 = EQ \end{code} - -%************************************************************************ -%* * -\subsubsection{The @SimplEnv@ type} -%* * -%************************************************************************ - - -\begin{code} -data SimplEnv - = SimplEnv { - seMode :: SimplifierMode, - seChkr :: SwitchChecker, - seCC :: CostCentreStack, -- The enclosing CCS (when profiling) - seSubst :: Subst -- The current substitution - } - -- The range of the substitution is OutType and OutExpr resp - -- - -- The substitution is idempotent - -- It *must* be applied; things in its domain simply aren't - -- bound in the result. - -- - -- The substitution usually maps an Id to its clone, - -- but if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just add the binding to the substitution and elide the let. - - -- The in-scope part of Subst includes *all* in-scope TyVars and Ids - -- The elements of the set may have better IdInfo than the - -- occurrences of in-scope Ids, and (more important) they will - -- have a correctly-substituted type. So we use a lookup in this - -- set to replace occurrences - -emptySimplEnv :: SimplifierMode -> [SimplifierSwitch] -> VarSet -> SimplEnv -emptySimplEnv mode switches in_scope - = SimplEnv { seChkr = isAmongSimpl switches, seCC = subsumedCCS, seMode = mode, - seSubst = mkSubst (mkInScopeSet in_scope) emptySubstEnv } - -- The top level "enclosing CC" is "SUBSUMED". - ---------------------- -getSwitchChecker :: SimplEnv -> SwitchChecker -getSwitchChecker env = seChkr env - ---------------------- -getMode :: SimplEnv -> SimplifierMode -getMode env = seMode env - -setMode :: SimplifierMode -> SimplEnv -> SimplEnv -setMode mode env = env { seMode = mode } - ---------------------- -getEnclosingCC :: SimplEnv -> CostCentreStack -getEnclosingCC env = seCC env - -setEnclosingCC :: SimplEnv -> CostCentreStack -> SimplEnv -setEnclosingCC env cc = env {seCC = cc} - ---------------------- -getSubst :: SimplEnv -> Subst -getSubst env = seSubst env - -setSubst :: SimplEnv -> Subst -> SimplEnv -setSubst env subst = env {seSubst = subst} - -extendSubst :: SimplEnv -> CoreBndr -> SubstResult -> SimplEnv -extendSubst env@(SimplEnv {seSubst = subst}) var res - = env {seSubst = Subst.extendSubst subst var res} - -extendSubstList :: SimplEnv -> [CoreBndr] -> [SubstResult] -> SimplEnv -extendSubstList env@(SimplEnv {seSubst = subst}) vars ress - = env {seSubst = Subst.extendSubstList subst vars ress} - ---------------------- -getInScope :: SimplEnv -> InScopeSet -getInScope env = substInScope (seSubst env) - -setInScope :: SimplEnv -> SimplEnv -> SimplEnv -setInScope env env_with_in_scope = setInScopeSet env (getInScope env_with_in_scope) - -setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv -setInScopeSet env@(SimplEnv {seSubst = subst}) in_scope - = env {seSubst = Subst.setInScope subst in_scope} - -addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv - -- The new Ids are guaranteed to be freshly allocated -addNewInScopeIds env@(SimplEnv {seSubst = subst}) vs - = env {seSubst = Subst.extendNewInScopeList subst vs} - -modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv -modifyInScope env@(SimplEnv {seSubst = subst}) v v' - = env {seSubst = Subst.modifyInScope subst v v'} - ---------------------- -getSubstEnv :: SimplEnv -> SubstEnv -getSubstEnv env = substEnv (seSubst env) - -setSubstEnv :: SimplEnv -> SubstEnv -> SimplEnv -setSubstEnv env@(SimplEnv {seSubst = subst}) senv - = env {seSubst = Subst.setSubstEnv subst senv} - -zapSubstEnv :: SimplEnv -> SimplEnv -zapSubstEnv env@(SimplEnv {seSubst = subst}) - = env {seSubst = Subst.zapSubstEnv subst} -\end{code} - - -%************************************************************************ -%* * -\subsection{Decisions about inlining} -%* * -%************************************************************************ - -Inlining is controlled partly by the SimplifierMode switch. This has two -settings: - - SimplGently (a) Simplifying before specialiser/full laziness - (b) Simplifiying inside INLINE pragma - (c) Simplifying the LHS of a rule - (d) Simplifying a GHCi expression or Template - Haskell splice - - SimplPhase n Used at all other times - -The key thing about SimplGently is that it does no call-site inlining. -Before full laziness we must be careful not to inline wrappers, -because doing so inhibits floating - e.g. ...(case f x of ...)... - ==> ...(case (case x of I# x# -> fw x#) of ...)... - ==> ...(case x of I# x# -> case fw x# of ...)... -and now the redex (f x) isn't floatable any more. - -The no-inling thing is also important for Template Haskell. You might be -compiling in one-shot mode with -O2; but when TH compiles a splice before -running it, we don't want to use -O2. Indeed, we don't want to inline -anything, because the byte-code interpreter might get confused about -unboxed tuples and suchlike. - -INLINE pragmas -~~~~~~~~~~~~~~ -SimplGently is also used as the mode to simplify inside an InlineMe note. - -\begin{code} -inlineMode :: SimplifierMode -inlineMode = SimplGently -\end{code} - -It really is important to switch off inlinings inside such -expressions. Consider the following example - - let f = \pq -> BIG - in - let g = \y -> f y y - {-# INLINE g #-} - in ...g...g...g...g...g... - -Now, if that's the ONLY occurrence of f, it will be inlined inside g, -and thence copied multiple times when g is inlined. - - -This function may be inlinined in other modules, so we -don't want to remove (by inlining) calls to functions that have -specialisations, or that may have transformation rules in an importing -scope. - -E.g. {-# INLINE f #-} - f x = ...g... - -and suppose that g is strict *and* has specialisations. If we inline -g's wrapper, we deny f the chance of getting the specialised version -of g when f is inlined at some call site (perhaps in some other -module). - -It's also important not to inline a worker back into a wrapper. -A wrapper looks like - wraper = inline_me (\x -> ...worker... ) -Normally, the inline_me prevents the worker getting inlined into -the wrapper (initially, the worker's only call site!). But, -if the wrapper is sure to be called, the strictness analyser will -mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf -continuation. That's why the keep_inline predicate returns True for -ArgOf continuations. It shouldn't do any harm not to dissolve the -inline-me note under these circumstances. - -Note that the result is that we do very little simplification -inside an InlineMe. - - all xs = foldr (&&) True xs - any p = all . map p {-# INLINE any #-} - -Problem: any won't get deforested, and so if it's exported and the -importer doesn't use the inlining, (eg passes it as an arg) then we -won't get deforestation at all. We havn't solved this problem yet! - - -preInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~ -@preInlineUnconditionally@ examines a bndr to see if it is used just -once in a completely safe way, so that it is safe to discard the -binding inline its RHS at the (unique) usage site, REGARDLESS of how -big the RHS might be. If this is the case we don't simplify the RHS -first, but just inline it un-simplified. - -This is much better than first simplifying a perhaps-huge RHS and then -inlining and re-simplifying it. Indeed, it can be at least quadratically -better. Consider - - x1 = e1 - x2 = e2[x1] - x3 = e3[x2] - ...etc... - xN = eN[xN-1] - -We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc. - -NB: we don't even look at the RHS to see if it's trivial -We might have - x = y -where x is used many times, but this is the unique occurrence of y. -We should NOT inline x at all its uses, because then we'd do the same -for y -- aargh! So we must base this pre-rhs-simplification decision -solely on x's occurrences, not on its rhs. - -Evne RHSs labelled InlineMe aren't caught here, because there might be -no benefit from inlining at the call site. - -[Sept 01] Don't unconditionally inline a top-level thing, because that -can simply make a static thing into something built dynamically. E.g. - x = (a,b) - main = \s -> h x - -[Remember that we treat \s as a one-shot lambda.] No point in -inlining x unless there is something interesting about the call site. - -But watch out: if you aren't careful, some useful foldr/build fusion -can be lost (most notably in spectral/hartel/parstof) because the -foldr didn't see the build. Doing the dynamic allocation isn't a big -deal, in fact, but losing the fusion can be. But the right thing here -seems to be to do a callSiteInline based on the fact that there is -something interesting about the call site (it's strict). Hmm. That -seems a bit fragile. - -Conclusion: inline top level things gaily until Phase 0 (the last -phase), at which point don't. - -\begin{code} -preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool -preInlineUnconditionally env top_lvl bndr - | isTopLevel top_lvl, SimplPhase 0 <- phase = False --- If we don't have this test, consider --- x = length [1,2,3] --- The full laziness pass carefully floats all the cons cells to --- top level, and preInlineUnconditionally floats them all back in. --- Result is (a) static allocation replaced by dynamic allocation --- (b) many simplifier iterations because this tickles --- a related problem; only one inlining per pass --- --- On the other hand, I have seen cases where top-level fusion is --- lost if we don't inline top level thing (e.g. string constants) --- Hence the test for phase zero (which is the phase for all the final --- simplifications). Until phase zero we take no special notice of --- top level things, but then we become more leery about inlining --- them. - - | not active = False - | opt_SimplNoPreInlining = False - | otherwise = case idOccInfo bndr of - IAmDead -> True -- Happens in ((\x.1) v) - OneOcc in_lam once -> not in_lam && once - -- Not inside a lambda, one occurrence ==> safe! - other -> False - where - phase = getMode env - active = case phase of - SimplGently -> isAlwaysActive prag - SimplPhase n -> isActive n prag - prag = idInlinePragma bndr -\end{code} - -postInlineUnconditionally -~~~~~~~~~~~~~~~~~~~~~~~~~ -@postInlineUnconditionally@ decides whether to unconditionally inline -a thing based on the form of its RHS; in particular if it has a -trivial RHS. If so, we can inline and discard the binding altogether. - -NB: a loop breaker has must_keep_binding = True and non-loop-breakers -only have *forward* references Hence, it's safe to discard the binding - -NOTE: This isn't our last opportunity to inline. We're at the binding -site right now, and we'll get another opportunity when we get to the -ocurrence(s) - -Note that we do this unconditional inlining only for trival RHSs. -Don't inline even WHNFs inside lambdas; doing so may simply increase -allocation when the function is called. This isn't the last chance; see -NOTE above. - -NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why? -Because we don't even want to inline them into the RHS of constructor -arguments. See NOTE above - -NB: At one time even NOINLINE was ignored here: if the rhs is trivial -it's best to inline it anyway. We often get a=E; b=a from desugaring, -with both a and b marked NOINLINE. But that seems incompatible with -our new view that inlining is like a RULE, so I'm sticking to the 'active' -story for now. - -\begin{code} -postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool -postInlineUnconditionally env bndr occ_info rhs - = exprIsTrivial rhs - && active - && not (isLoopBreaker occ_info) - && not (isExportedId bndr) - -- We used to have (isOneOcc occ_info) instead of - -- not (isLoopBreaker occ_info) && not (isExportedId bndr) - -- That was because a rather fragile use of rules got confused - -- if you inlined even a binding f=g e.g. We used to have - -- map = mapList - -- But now a more precise use of phases has eliminated this problem, - -- so the is_active test will do the job. I think. - -- - -- OLD COMMENT: (delete soon) - -- Indeed, you might suppose that - -- there is nothing wrong with substituting for a trivial RHS, even - -- if it occurs many times. But consider - -- x = y - -- h = _inline_me_ (...x...) - -- Here we do *not* want to have x inlined, even though the RHS is - -- trivial, becuase the contract for an INLINE pragma is "no inlining". - -- This is important in the rules for the Prelude - where - active = case getMode env of - SimplGently -> isAlwaysActive prag - SimplPhase n -> isActive n prag - prag = idInlinePragma bndr - -activeInline :: SimplEnv -> OutId -> OccInfo -> Bool -activeInline env id occ - = case getMode env of - SimplGently -> isOneOcc occ && isAlwaysActive prag - -- No inlining at all when doing gentle stuff, - -- except for local things that occur once - -- The reason is that too little clean-up happens if you - -- don't inline use-once things. Also a bit of inlining is *good* for - -- full laziness; it can expose constant sub-expressions. - -- Example in spectral/mandel/Mandel.hs, where the mandelset - -- function gets a useful let-float if you inline windowToViewport - - -- NB: we used to have a second exception, for data con wrappers. - -- On the grounds that we use gentle mode for rule LHSs, and - -- they match better when data con wrappers are inlined. - -- But that only really applies to the trivial wrappers (like (:)), - -- and they are now constructed as Compulsory unfoldings (in MkId) - -- so they'll happen anyway. - - SimplPhase n -> isActive n prag - where - prag = idInlinePragma id - -activeRule :: SimplEnv -> Maybe (Activation -> Bool) --- Nothing => No rules at all -activeRule env - = case getMode env of - SimplGently -> Just isAlwaysActive - -- Used to be Nothing (no rules in gentle mode) - -- Main motivation for changing is that I wanted - -- lift String ===> ... - -- to work in Template Haskell when simplifying - -- splices, so we get simpler code for literal strings - SimplPhase n -> Just (isActive n) -\end{code} - - %************************************************************************ %* * \subsubsection{Command-line switches} @@ -944,29 +435,6 @@ activeRule env %************************************************************************ \begin{code} -getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int -getSimplIntSwitch chkr switch - = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) - -switchIsOn :: (switch -> SwitchResult) -> switch -> Bool - -switchIsOn lookup_fn switch - = case (lookup_fn switch) of - SwBool False -> False - _ -> True - -intSwitchSet :: (switch -> SwitchResult) - -> (Int -> switch) - -> Maybe Int - -intSwitchSet lookup_fn switch - = case (lookup_fn (switch (panic "intSwitchSet"))) of - SwInt int -> Just int - _ -> Nothing -\end{code} - - -\begin{code} type SwitchChecker = SimplifierSwitch -> SwitchResult data SwitchResult @@ -1014,6 +482,29 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* || sw `is_elem` ss \end{code} +\begin{code} +getSimplIntSwitch :: SwitchChecker -> (Int-> SimplifierSwitch) -> Int +getSimplIntSwitch chkr switch + = expectJust "getSimplIntSwitch" (intSwitchSet chkr switch) + +switchIsOn :: (switch -> SwitchResult) -> switch -> Bool + +switchIsOn lookup_fn switch + = case (lookup_fn switch) of + SwBool False -> False + _ -> True + +intSwitchSet :: (switch -> SwitchResult) + -> (Int -> switch) + -> Maybe Int + +intSwitchSet lookup_fn switch + = case (lookup_fn (switch (panic "intSwitchSet"))) of + SwInt int -> Just int + _ -> Nothing +\end{code} + + These things behave just like enumeration types. \begin{code}