\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecBndrs,
- simplLetBndr, simplLamBndrs,
- newId, mkLam, prepareAlts, mkCase,
+ mkLam, prepareAlts, mkCase,
+
+ -- Inlining,
+ preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
+ inlineMode,
-- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..),
#include "HsVersions.h"
-import CmdLineOpts ( SimplifierSwitch(..), opt_UF_UpdateInPlace,
+import SimplEnv
+import DynFlags ( SimplifierSwitch(..), SimplifierMode(..),
DynFlag(..), dopt )
+import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
+ opt_RulesOff )
+
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
+import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
- findDefault, exprOkForSpeculation, exprIsValue
+ findDefault, exprOkForSpeculation, exprIsHNF
)
-import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo, isDataConWorkId,
- mkSysLocal, isDeadBinder, idNewDemandInfo,
- idUnfolding, idNewStrictness
+import Literal ( mkStringLit )
+import CoreUnfold ( smallEnoughToInline )
+import MkId ( eRROR_ID )
+import Id ( idType, isDataConWorkId, idOccInfo, isDictId,
+ mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
+ idUnfolding, idNewStrictness, idInlinePragma,
)
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
-import Type ( Type, seqType, splitFunTys, dropForAlls, isStrictType,
+import Type ( Type, splitFunTys, dropForAlls, isStrictType,
splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
)
-import TcType ( isDictTy )
import Name ( mkSysTvName )
-import OccName ( EncodedFS )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
-import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
+import DataCon ( dataConRepArity, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
import Var ( tyVarKind, mkTyVar )
import VarSet
-import Util ( lengthExceeds, mapAccumL )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
+ Activation, isAlwaysActive, isActive )
+import Util ( lengthExceeds )
import Outputable
\end{code}
%************************************************************************
%* *
-\section{Dealing with a single binder}
+\subsection{Decisions about inlining}
%* *
%************************************************************************
-These functions are in the monad only so that they can be made strict via seq.
+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}
-simplBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplBinders env bndrs
- = let
- (subst', bndrs') = Subst.simplBndrs (getSubst env) bndrs
- in
- seqBndrs bndrs' `seq`
- returnSmpl (setSubst env subst', bndrs')
+inlineMode :: SimplifierMode
+inlineMode = SimplGently
+\end{code}
-simplBinder :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplBinder env bndr
- = let
- (subst', bndr') = Subst.simplBndr (getSubst env) bndr
- in
- seqBndr bndr' `seq`
- returnSmpl (setSubst env subst', bndr')
+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.
+This can happen with cascades of functions too:
-simplLetBndr :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplLetBndr env id
- = let
- (subst', id') = Subst.simplLetId (getSubst env) id
- in
- seqBndr id' `seq`
- returnSmpl (setSubst env subst', id')
+ f1 = \x1.e1
+ f2 = \xs.e2[f1]
+ f3 = \xs.e3[f3]
+ ...etc...
-simplLamBndrs, simplRecBndrs
- :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplRecBndrs = simplBndrs Subst.simplLetId
-simplLamBndrs = simplBndrs Subst.simplLamBndr
+THE MAIN INVARIANT is this:
-simplBndrs simpl_bndr env bndrs
- = let
- (subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs
- in
- seqBndrs bndrs' `seq`
- returnSmpl (setSubst env subst', bndrs')
+ ---- preInlineUnconditionally invariant -----
+ IF preInlineUnconditionally chooses to inline x = <rhs>
+ THEN doing the inlining should not change the occurrence
+ info for the free vars of <rhs>
+ ----------------------------------------------
-seqBndrs [] = ()
-seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+For example, it's tempting to look at trivial binding like
+ x = y
+and inline it unconditionally. But suppose x is used many times,
+but this is the unique occurrence of y. Then inlining x would change
+y's occurrence info, which breaks the invariant. It matters: y
+might have a BIG rhs, which will now be dup'd at every occurrenc of x.
-seqBndr b | isTyVar b = b `seq` ()
- | otherwise = seqType (idType b) `seq`
- idInfo b `seq`
- ()
-\end{code}
+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}
-newId :: EncodedFS -> Type -> SimplM Id
-newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
- returnSmpl (mkSysLocal fs uniq ty)
+preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
+preInlineUnconditionally env top_lvl bndr rhs
+ | not active = False
+ | opt_SimplNoPreInlining = False
+ | otherwise = case idOccInfo bndr of
+ IAmDead -> True -- Happens in ((\x.1) v)
+ OneOcc in_lam True int_cxt -> try_once in_lam int_cxt
+ other -> False
+ where
+ phase = getMode env
+ active = case phase of
+ SimplGently -> isAlwaysActive prag
+ SimplPhase n -> isActive n prag
+ prag = idInlinePragma bndr
+
+ try_once in_lam int_cxt -- There's one textual occurrence
+ | not in_lam = isNotTopLevel top_lvl || early_phase
+ | otherwise = int_cxt && canInlineInLam rhs
+
+-- Be very careful before inlining inside a lambda, becuase (a) we must not
+-- invalidate occurrence information, and (b) we want to avoid pushing a
+-- single allocation (here) into multiple allocations (inside lambda).
+-- Inlining a *function* with a single *saturated* call would be ok, mind you.
+-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
+-- where
+-- is_cheap = exprIsCheap rhs
+-- ok = is_cheap && int_cxt
+
+ -- int_cxt The context isn't totally boring
+ -- E.g. let f = \ab.BIG in \y. map f xs
+ -- Don't want to substitute for f, because then we allocate
+ -- its closure every time the \y is called
+ -- But: let f = \ab.BIG in \y. map (f y) xs
+ -- Now we do want to substitute for f, even though it's not
+ -- saturated, because we're going to allocate a closure for
+ -- (f y) every time round the loop anyhow.
+
+ -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
+ -- so substituting rhs inside a lambda doesn't change the occ info.
+ -- Sadly, not quite the same as exprIsHNF.
+ canInlineInLam (Lit l) = True
+ canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e
+ canInlineInLam (Note _ e) = canInlineInLam e
+ canInlineInLam _ = False
+
+ early_phase = case phase of
+ SimplPhase 0 -> False
+ other -> True
+-- If we don't have this early_phase 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.
+
\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 -> TopLevelFlag -> OutId -> OccInfo -> OutExpr -> Unfolding -> Bool
+postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
+ | not active = False
+ | isLoopBreaker occ_info = False
+ | isExportedId bndr = False
+ | exprIsTrivial rhs = True
+ | otherwise
+ = case occ_info of
+ OneOcc in_lam one_br int_cxt
+ -> (one_br || smallEnoughToInline unfolding) -- Small enough to dup
+ -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
+ --
+ -- NB: Do we want to inline arbitrarily big things becuase
+ -- one_br is True? that can lead to inline cascades. But
+ -- preInlineUnconditionlly has dealt with all the common cases
+ -- so perhaps it's worth the risk. Here's an example
+ -- let f = if b then Left (\x.BIG) else Right (\y.BIG)
+ -- in \y. ....f....
+ -- We can't preInlineUnconditionally because that woud invalidate
+ -- the occ info for b. Yet f is used just once, and duplicating
+ -- the case work is fine (exprIsCheap).
+
+ && ((isNotTopLevel top_lvl && not in_lam) ||
+ -- But outside a lambda, we want to be reasonably aggressive
+ -- about inlining into multiple branches of case
+ -- e.g. let x = <non-value>
+ -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
+ -- Inlining can be a big win if C3 is the hot-spot, even if
+ -- the uses in C1, C2 are not 'interesting'
+ -- An example that gets worse if you add int_cxt here is 'clausify'
+
+ (isCheapUnfolding unfolding && int_cxt))
+ -- isCheap => acceptable work duplication; in_lam may be true
+ -- int_cxt to prevent us inlining inside a lambda without some
+ -- good reason. See the notes on int_cxt in preInlineUnconditionally
+
+ other -> False
+ -- The point here is that for *non-values* that occur
+ -- outside a lambda, the call-site inliner won't have
+ -- a chance (becuase it doesn't know that the thing
+ -- only occurs once). The pre-inliner won't have gotten
+ -- it either, if the thing occurs in more than one branch
+ -- So the main target is things like
+ -- let x = f y in
+ -- case v of
+ -- True -> case x of ...
+ -- False -> case x of ...
+ -- I'm not sure how important this is in practice
+ 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
+ | opt_RulesOff = Nothing
+ | otherwise
+ = 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}
+
%************************************************************************
%* *
ok_fun fun = exprIsTrivial fun
&& not (any (`elemVarSet` (exprFreeVars fun)) bndrs)
- && (exprIsValue fun || all ok_lam bndrs)
- ok_lam v = isTyVar v || isDictTy (idType v)
- -- The exprIsValue is because eta reduction is not
+ && (exprIsHNF fun || all ok_lam bndrs)
+ ok_lam v = isTyVar v || isDictId v
+ -- The exprIsHNF is because eta reduction is not
-- valid in general: \x. bot /= bot
-- So we need to be sure that the "fun" is a value.
--
\begin{code}
prepareAlts :: OutExpr -- Scrutinee
- -> InId -- Case binder
+ -> InId -- Case binder (passed only to use in statistics)
-> [InAlt] -- Increasing order
-> SimplM ([InAlt], -- Better alternatives, still incresaing order
[AltCon]) -- These cases are handled
-- Filter out the default, if it can't happen,
-- or replace it with "proper" alternative if there
-- is only one constructor left
- prepareDefault case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
+ prepareDefault scrut case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
-- We need the mergeAlts in case the new default_alt
-- has turned into a constructor alternative.
-prepareDefault case_bndr handled_cons (Just rhs)
- | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
+prepareDefault scrut case_bndr handled_cons (Just rhs)
+ | Just (tycon, inst_tys) <- splitTyConApp_maybe (exprType scrut),
+ -- Use exprType scrut here, rather than idType case_bndr, because
+ -- case_bndr is an InId, so exprType scrut may have more information
+ -- Test simpl013 is an example
isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
-- case x of { DEFAULT -> e }
| otherwise
= returnSmpl [(DEFAULT, [], rhs)]
-prepareDefault case_bndr handled_cons Nothing
+prepareDefault scrut case_bndr handled_cons Nothing
= returnSmpl []
mk_args missing_con inst_tys
= mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
- let arg_tys = dataConArgTys missing_con inst_tys'
+ let arg_tys = dataConInstArgTys missing_con inst_tys'
arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
in
returnSmpl (tv_bndrs ++ arg_ids)
-- 0. Check for empty alternatives
--------------------------------------------------
-#ifdef DEBUG
+-- This isn't strictly an error. It's possible that the simplifer might "see"
+-- that an inner case has no accessible alternatives before it "sees" that the
+-- entire branch of an outer case is inaccessible. So we simply
+-- put an error case here insteadd
mkCase1 scrut case_bndr ty []
= pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
- returnSmpl scrut
-#endif
+ return (mkApps (Var eRROR_ID)
+ [Type ty, Lit (mkStringLit "Impossible alternative")])
--------------------------------------------------
-- 1. Eliminate the case altogether if poss
-- x
-- This particular example shows up in default methods for
-- comparision operations (e.g. in (>=) for Int.Int32)
- || exprIsValue scrut -- It's already evaluated
+ || exprIsHNF scrut -- It's already evaluated
|| var_demanded_later scrut -- It'll be demanded later
-- || not opt_SimplPedanticBottoms) -- Or we don't care!