\begin{code}
module SimplUtils (
- simplBinder, simplBinders, simplRecIds, simplLetId, simplLamBinders,
- tryEtaExpansion,
- newId, mkLam, mkCase,
+ mkLam, prepareAlts, mkCase,
+
+ -- Inlining,
+ preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
+ inlineMode,
-- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..),
contIsDupable, contResultType,
- countValArgs, countArgs,
- mkBoringStop, mkStop, contIsRhs, contIsRhsOrArg,
- getContArgs, interestingCallContext, interestingArg, isStrictType, discardInline
+ countValArgs, countArgs, pushContArgs,
+ mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
+ getContArgs, interestingCallContext, interestingArg, isStrictType
) where
#include "HsVersions.h"
-import CmdLineOpts ( SimplifierSwitch(..),
- opt_SimplDoLambdaEtaExpansion, opt_SimplDoEtaReduction,
- opt_SimplCaseMerge, opt_UF_UpdateInPlace
- )
+import SimplEnv
+import CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), opt_UF_UpdateInPlace,
+ opt_SimplNoPreInlining, opt_RulesOff,
+ DynFlag(..), dopt )
import CoreSyn
-import CoreFVs ( exprSomeFreeVars, exprsSomeFreeVars )
-import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap,
- etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
+import CoreFVs ( exprFreeVars )
+import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
+ etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
findDefault, exprOkForSpeculation, exprIsValue
)
-import Subst ( InScopeSet, mkSubst, substExpr )
-import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idName,
- mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo,
- idUnfolding, idNewStrictness,
- mkLocalId, idInfo
+import Id ( Id, idType, idInfo, isDataConWorkId, idOccInfo,
+ mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
+ idUnfolding, idNewStrictness, idInlinePragma,
)
-import Name ( setNameUnique )
import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
import SimplMonad
-import Type ( Type, mkForAllTys, seqType,
- splitTyConApp_maybe, tyConAppArgs, mkTyVarTys,
- isUnLiftedType, splitRepFunTys, isStrictType
+import Type ( Type, seqType, splitFunTys, dropForAlls, isStrictType,
+ splitTyConApp_maybe, tyConAppArgs, mkTyVarTys
)
-import OccName ( UserFS )
-import TyCon ( tyConDataConsIfAvailable, isDataTyCon )
-import DataCon ( dataConRepArity, dataConSig, dataConArgTys )
-import Var ( mkSysTyVar, tyVarKind )
-import VarEnv ( SubstEnv )
-import VarSet ( mkVarSet, varSetElems, intersectVarSet )
+import TcType ( isDictTy )
+import Name ( mkSysTvName )
+import OccName ( EncodedFS )
+import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
+import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
+import Var ( tyVarKind, mkTyVar )
+import VarSet
+import BasicTypes ( TopLevelFlag(..), isTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
+ Activation, isAlwaysActive, isActive )
import Util ( lengthExceeds, mapAccumL )
import Outputable
\end{code}
InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
SimplCont
- | ArgOf DupFlag -- An arbitrary strict context: the argument
+ | ArgOf LetRhsFlag -- An arbitrary strict context: the argument
-- of a strict function, or a primitive-arg fn
-- or a PrimOp
- LetRhsFlag
+ -- No DupFlag because we never duplicate it
+ OutType -- arg_ty: type of the argument itself
OutType -- cont_ty: 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.
+
(SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- What to do with the result
-- The result expression in the OutExprStuff has type cont_ty
instance Outputable SimplCont where
ppr (Stop _ is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs)
ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
- ppr (ArgOf dup _ _ _) = ptext SLIT("ArgOf...") <+> ppr dup
+ ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
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
-------------------
-mkBoringStop :: OutType -> SimplCont
+mkBoringStop, mkRhsStop :: OutType -> SimplCont
mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
-
-mkStop :: OutType -> LetRhsFlag -> SimplCont
-mkStop ty is_rhs = Stop ty is_rhs (canUpdateInPlace ty)
+mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
contIsRhs :: SimplCont -> Bool
contIsRhs (Stop _ AnRhs _) = True
-contIsRhs (ArgOf _ AnRhs _ _) = True
+contIsRhs (ArgOf AnRhs _ _ _) = True
contIsRhs other = False
contIsRhsOrArg (Stop _ _ _) = True
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
-
--------------------
-discardInline :: SimplCont -> SimplCont
-discardInline (InlinePlease cont) = cont
-discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
-discardInline cont = cont
+contIsDupable (InlinePlease cont) = contIsDupable cont
+contIsDupable other = False
-------------------
discardableCont :: SimplCont -> Bool
countArgs :: SimplCont -> Int
countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
countArgs other = 0
+
+-------------------
+pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
+-- Pushes args with the specified environment
+pushContArgs env [] cont = cont
+pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
\end{code}
-- * (error "Hello") arg
-- * f (error "Hello") where f is strict
-- etc
+ -- Then, especially in the first of these cases, we'd like to discard
+ -- the continuation, leaving just the bottoming expression. But the
+ -- type might not be right, so we may have to add a coerce.
go acc ss inl cont
| null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
| otherwise = (reverse acc, cont, inl)
computed_stricts = zipWith (||) fun_stricts arg_stricts
----------------------------
- (val_arg_tys, _) = splitRepFunTys (idType fun)
+ (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun))
arg_stricts = map isStrictType val_arg_tys ++ repeat False
-- These argument types are used as a cheap and cheerful way to find
-- unboxed arguments, which must be strict. But it's an InType
-- and so there might be a type variable where we expect a function
-- type (the substitution hasn't happened yet). And we don't bother
-- doing the type applications for a polymorphic function.
- -- Hence the split*Rep*FunTys
+ -- Hence the splitFunTys*IgnoringForAlls*
----------------------------
-- If fun_stricts is finite, it means the function returns bottom
other -> vanilla_stricts -- Not enough args, or no strictness
-------------------
-interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
+interestingArg :: OutExpr -> Bool
-- An argument is interesting if it has *some* structure
-- We are here trying to avoid unfolding a function that
-- is applied only to variables that have no unfolding
-- (i.e. they are probably lambda bound): f x y z
-- There is little point in inlining f here.
-interestingArg in_scope arg subst
- = analyse (substExpr (mkSubst in_scope subst) arg)
- -- 'analyse' only looks at the top part of the result
- -- and substExpr is lazy, so this isn't nearly as brutal
- -- as it looks.
- where
- analyse (Var v) = hasSomeUnfolding (idUnfolding v)
- -- Was: isValueUnfolding (idUnfolding v')
- -- But that seems over-pessimistic
- analyse (Type _) = False
- analyse (App fn (Type _)) = analyse fn
- analyse (Note _ a) = analyse a
- analyse other = True
+interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
+ -- Was: isValueUnfolding (idUnfolding v')
+ -- But that seems over-pessimistic
+ || isDataConWorkId v
+ -- This accounts for an argument like
+ -- () or [], which is definitely interesting
+interestingArg (Type _) = False
+interestingArg (App fn (Type _)) = interestingArg fn
+interestingArg (Note _ a) = interestingArg a
+interestingArg other = True
-- Consider let x = 3 in f x
-- The substitution will contain (x -> ContEx 3), and we want to
-- to say that x is an interesting argument.
interestingCallContext some_args some_val_args cont
= interesting cont
where
- interesting (InlinePlease _) = True
- interesting (Select _ _ _ _ _) = some_args
- interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
+ interesting (InlinePlease _) = True
+ interesting (Select _ _ _ _ _) = some_args
+ interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
-- Perhaps True is a bit over-keen, but I've
-- seen (coerce f) x, where f has an INLINE prag,
-- So we have to give some motivaiton for inlining it
| otherwise
= case splitTyConApp_maybe ty of
Nothing -> False
- Just (tycon, _) -> case tyConDataConsIfAvailable tycon of
- [dc] -> arity == 1 || arity == 2
- where
- arity = dataConRepArity dc
+ Just (tycon, _) -> case tyConDataCons_maybe tycon of
+ Just [dc] -> arity == 1 || arity == 2
+ where
+ arity = dataConRepArity dc
other -> False
\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.
-simplLamBinders :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplLamBinders env bndrs
- = let
- (subst', bndrs') = mapAccumL Subst.simplLamBndr (getSubst env) bndrs
- in
- seqBndrs bndrs' `seq`
- returnSmpl (setSubst env subst', bndrs')
+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.
-simplRecIds :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder])
-simplRecIds env ids
- = let
- (subst', ids') = mapAccumL Subst.simplLetId (getSubst env) ids
- in
- seqBndrs ids' `seq`
- returnSmpl (setSubst env subst', ids')
+Evne RHSs labelled InlineMe aren't caught here, because there might be
+no benefit from inlining at the call site.
-simplLetId :: SimplEnv -> InBinder -> SimplM (SimplEnv, OutBinder)
-simplLetId env id
- = let
- (subst', id') = Subst.simplLetId (getSubst env) id
- in
- seqBndr id' `seq`
- returnSmpl (setSubst env subst', id')
+[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
-seqBndrs [] = ()
-seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+[Remember that we treat \s as a one-shot lambda.] No point in
+inlining x unless there is something interesting about the call site.
-seqBndr b | isTyVar b = b `seq` ()
- | otherwise = seqType (idType b) `seq`
- idInfo b `seq`
- ()
-\end{code}
+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 :: UserFS -> Type -> SimplM Id
-newId fs ty = getUniqueSmpl `thenSmpl` \ uniq ->
- returnSmpl (mkSysLocal fs uniq ty)
+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
+ | 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}
+
%************************************************************************
%* *
\begin{code}
mkLam env bndrs body cont
- | opt_SimplDoEtaReduction,
- Just etad_lam <- tryEtaReduce bndrs body
- = tick (EtaReduction (head bndrs)) `thenSmpl_`
- returnSmpl (emptyFloats env, etad_lam)
-
- | opt_SimplDoLambdaEtaExpansion,
- any isRuntimeVar bndrs
- = tryEtaExpansion body `thenSmpl` \ body' ->
- returnSmpl (emptyFloats env, mkLams bndrs body')
+ = getDOptsSmpl `thenSmpl` \dflags ->
+ mkLam' dflags env bndrs body cont
+ where
+ mkLam' dflags env bndrs body cont
+ | dopt Opt_DoEtaReduction dflags,
+ Just etad_lam <- tryEtaReduce bndrs body
+ = tick (EtaReduction (head bndrs)) `thenSmpl_`
+ returnSmpl (emptyFloats env, etad_lam)
+
+ | dopt Opt_DoLambdaEtaExpansion dflags,
+ any isRuntimeVar bndrs
+ = tryEtaExpansion body `thenSmpl` \ body' ->
+ returnSmpl (emptyFloats env, mkLams bndrs body')
{- Sept 01: I'm experimenting with getting the
full laziness pass to float out past big lambdsa
returnSmpl (floats, mkLams bndrs body')
-}
- | otherwise
- = returnSmpl (emptyFloats env, mkLams bndrs body)
+ | otherwise
+ = returnSmpl (emptyFloats env, mkLams bndrs body)
\end{code}
-- efficient here:
-- (a) we already have the binders
-- (b) we can do the triviality test before computing the free vars
- -- [in fact I take the simple path and look for just a variable]
= go (reverse bndrs) body
where
go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round
- go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success!
+ go [] fun | ok_fun fun = Just fun -- Success!
go _ _ = Nothing -- Failure!
- ok_fun fun = not (fun `elem` bndrs) && not (hasNoBinding fun)
+ 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
+ -- valid in general: \x. bot /= bot
+ -- So we need to be sure that the "fun" is a value.
+ --
+ -- However, we always want to reduce (/\a -> f a) to f
+ -- This came up in a RULE: foldr (build (/\a -> g a))
+ -- did not match foldr (build (/\b -> ...something complex...))
+ -- The type checker can insert these eta-expanded versions,
+ -- with both type and dictionary lambdas; hence the slightly
+ -- ad-hoc isDictTy
+
ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
\end{code}
tryEtaExpansion :: OutExpr -> SimplM OutExpr
-- There is at least one runtime binder in the binders
tryEtaExpansion body
- | arity_is_manifest -- Some lambdas but not enough
- = returnSmpl body
-
- | otherwise
= getUniquesSmpl `thenSmpl` \ us ->
returnSmpl (etaExpand fun_arity us body (exprType body))
where
- (fun_arity, arity_is_manifest) = exprEtaExpandArity body
+ fun_arity = exprEtaExpandArity body
\end{code}
-}
\end{code}
+%************************************************************************
+%* *
+\subsection{Case alternative filtering
+%* *
+%************************************************************************
+
+prepareAlts does two things:
+
+1. Eliminate alternatives that cannot match, including the
+ DEFAULT alternative.
+
+2. If the DEFAULT alternative can match only one possible constructor,
+ then make that constructor explicit.
+ e.g.
+ case e of x { DEFAULT -> rhs }
+ ===>
+ case e of x { (a,b) -> rhs }
+ where the type is a single constructor type. This gives better code
+ when rhs also scrutinises x or e.
+
+It's a good idea do do this stuff before simplifying the alternatives, to
+avoid simplifying alternatives we know can't happen, and to come up with
+the list of constructors that are handled, to put into the IdInfo of the
+case binder, for use when simplifying the alternatives.
+
+Eliminating the default alternative in (1) isn't so obvious, but it can
+happen:
+
+data Colour = Red | Green | Blue
+
+f x = case x of
+ Red -> ..
+ Green -> ..
+ DEFAULT -> h x
+
+h y = case y of
+ Blue -> ..
+ DEFAULT -> [ case y of ... ]
+
+If we inline h into f, the default case of the inlined h can't happen.
+If we don't notice this, we may end up filtering out *all* the cases
+of the inner case y, which give us nowhere to go!
+
+
+\begin{code}
+prepareAlts :: OutExpr -- Scrutinee
+ -> InId -- Case binder
+ -> [InAlt] -- Increasing order
+ -> SimplM ([InAlt], -- Better alternatives, still incresaing order
+ [AltCon]) -- These cases are handled
+
+prepareAlts scrut case_bndr alts
+ = let
+ (alts_wo_default, maybe_deflt) = findDefault alts
+
+ impossible_cons = case scrut of
+ Var v -> otherCons (idUnfolding v)
+ other -> []
+
+ -- Filter out alternatives that can't possibly match
+ better_alts | null impossible_cons = alts_wo_default
+ | otherwise = [alt | alt@(con,_,_) <- alts_wo_default,
+ not (con `elem` impossible_cons)]
+
+ -- "handled_cons" are handled either by the context,
+ -- or by a branch in this case expression
+ -- (Don't add DEFAULT to the handled_cons!!)
+ handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
+ in
+ -- 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 ->
+
+ 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),
+ 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 }
+ -- and we don't want to fill in a default for them!
+ Just all_cons <- tyConDataCons_maybe tycon,
+ not (null all_cons), -- This is a tricky corner case. If the data type has no constructors,
+ -- which GHC allows, then the case expression will have at most a default
+ -- alternative. We don't want to eliminate that alternative, because the
+ -- invariant is that there's always one alternative. It's more convenient
+ -- to leave
+ -- case x of { DEFAULT -> e }
+ -- as it is, rather than transform it to
+ -- error "case cant match"
+ -- which would be quite legitmate. But it's a really obscure corner, and
+ -- not worth wasting code on.
+ let handled_data_cons = [data_con | DataAlt data_con <- handled_cons],
+ let missing_cons = [con | con <- all_cons,
+ not (con `elem` handled_data_cons)]
+ = case missing_cons of
+ [] -> returnSmpl [] -- Eliminate the default alternative
+ -- if it can't match
+
+ [con] -> -- It matches exactly one constructor, so fill it in
+ tick (FillInCaseDefault case_bndr) `thenSmpl_`
+ mk_args con inst_tys `thenSmpl` \ args ->
+ returnSmpl [(DataAlt con, args, rhs)]
+
+ two_or_more -> returnSmpl [(DEFAULT, [], rhs)]
+
+ | otherwise
+ = returnSmpl [(DEFAULT, [], rhs)]
+
+prepareDefault 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'
+ arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
+ in
+ returnSmpl (tv_bndrs ++ arg_ids)
+
+mk_tv_bndrs missing_con inst_tys
+ | isVanillaDataCon missing_con
+ = returnSmpl ([], inst_tys)
+ | otherwise
+ = getUniquesSmpl `thenSmpl` \ tv_uniqs ->
+ let new_tvs = zipWith mk tv_uniqs (dataConTyVars missing_con)
+ mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
+ in
+ returnSmpl (new_tvs, mkTyVarTys new_tvs)
+\end{code}
+
%************************************************************************
%* *
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
-mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
-
-mkCase scrut case_bndr alts
- = mkAlts scrut case_bndr alts `thenSmpl` \ better_alts ->
- mkCase1 scrut case_bndr better_alts
+mkCase :: OutExpr -> OutId -> OutType
+ -> [OutAlt] -- Increasing order
+ -> SimplM OutExpr
+
+mkCase scrut case_bndr ty alts
+ = getDOptsSmpl `thenSmpl` \dflags ->
+ mkAlts dflags scrut case_bndr alts `thenSmpl` \ better_alts ->
+ mkCase1 scrut case_bndr ty better_alts
\end{code}
a) all branches equal
b) some branches equal to the DEFAULT (which occurs first)
-2. If the DEFAULT alternative can match only one possible constructor,
- then make that constructor explicit.
- e.g.
- case e of x { DEFAULT -> rhs }
- ===>
- case e of x { (a,b) -> rhs }
- where the type is a single constructor type. This gives better code
- when rhs also scrutinises x or e.
-
-3. Case merging:
+2. Case merging:
case e of b { ==> case e of b {
p1 -> rhs1 p1 -> rhs1
... ...
--------------------------------------------------
-- 1. Merge identical branches
--------------------------------------------------
-mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
+mkAlts dflags scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
| all isDeadBinder bndrs1, -- Remember the default
length filtered_alts < length con_alts -- alternative comes first
= tick (AltMerge case_bndr) `thenSmpl_`
--------------------------------------------------
--- 2. Fill in missing constructor
+-- 2. Merge nested cases
--------------------------------------------------
-mkAlts scrut case_bndr alts
- | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
- isDataTyCon tycon, -- It's a data type
- (alts_no_deflt, Just rhs) <- findDefault alts,
- -- There is a DEFAULT case
- [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
- -- There is just one missing constructor!
- = tick (FillInCaseDefault case_bndr) `thenSmpl_`
- getUniquesSmpl `thenSmpl` \ tv_uniqs ->
- getUniquesSmpl `thenSmpl` \ id_uniqs ->
- let
- (_,_,ex_tyvars,_,_,_) = dataConSig missing_con
- ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
- mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
- arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys
- arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
- better_alts = (DataAlt missing_con, ex_tyvars' ++ arg_ids, rhs) : alts_no_deflt
- in
- returnSmpl better_alts
- where
- impossible_cons = otherCons (idUnfolding case_bndr)
- handled_data_cons = [data_con | DataAlt data_con <- impossible_cons] ++
- [data_con | (DataAlt data_con, _, _) <- alts]
- is_missing con = not (con `elem` handled_data_cons)
-
---------------------------------------------------
--- 3. Merge nested cases
---------------------------------------------------
-
-mkAlts scrut outer_bndr outer_alts
- | opt_SimplCaseMerge,
+mkAlts dflags scrut outer_bndr outer_alts
+ | dopt Opt_CaseMerge dflags,
(outer_alts_without_deflt, maybe_outer_deflt) <- findDefault outer_alts,
- Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
+ Just (Case (Var scrut_var) inner_bndr _ inner_alts) <- maybe_outer_deflt,
scruting_same_var scrut_var
-
- = let -- Eliminate any inner alts which are shadowed by the outer ones
- outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
-
- munged_inner_alts = [ (con, args, munge_rhs rhs)
- | (con, args, rhs) <- inner_alts,
- not (con `elem` outer_cons) -- Eliminate shadowed inner alts
- ]
- munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
-
- (inner_con_alts, maybe_inner_default) = findDefault munged_inner_alts
-
- new_alts = add_default maybe_inner_default
- (outer_alts_without_deflt ++ inner_con_alts)
+ = let
+ munged_inner_alts = [(con, args, munge_rhs rhs) | (con, args, rhs) <- inner_alts]
+ munge_rhs rhs = bindCaseBndr inner_bndr (Var outer_bndr) rhs
+
+ new_alts = mergeAlts outer_alts_without_deflt munged_inner_alts
+ -- The merge keeps the inner DEFAULT at the front, if there is one
+ -- and eliminates any inner_alts that are shadowed by the outer_alts
in
tick (CaseMerge outer_bndr) `thenSmpl_`
returnSmpl new_alts
- -- Warning: don't call mkAlts recursively!
- -- Firstly, there's no point, because inner alts have already had
- -- mkCase applied to them, so they won't have a case in their default
- -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
- -- in munge_rhs may put a case into the DEFAULT branch!
+ -- Warning: don't call mkAlts recursively!
+ -- Firstly, there's no point, because inner alts have already had
+ -- mkCase applied to them, so they won't have a case in their default
+ -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
+ -- in munge_rhs may put a case into the DEFAULT branch!
where
- -- We are scrutinising the same variable if it's
- -- the outer case-binder, or if the outer case scrutinises a variable
- -- (and it's the same). Testing both allows us not to replace the
- -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
+ -- We are scrutinising the same variable if it's
+ -- the outer case-binder, or if the outer case scrutinises a variable
+ -- (and it's the same). Testing both allows us not to replace the
+ -- outer scrut-var with the outer case-binder (Simplify.simplCaseBinder).
scruting_same_var = case scrut of
Var outer_scrut -> \ v -> v == outer_bndr || v == outer_scrut
other -> \ v -> v == outer_bndr
- add_default (Just rhs) alts = (DEFAULT,[],rhs) : alts
- add_default Nothing alts = alts
-
-
---------------------------------------------------
+------------------------------------------------
-- Catch-all
---------------------------------------------------
-
-mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+------------------------------------------------
+
+mkAlts dflags scrut case_bndr other_alts = returnSmpl other_alts
+
+
+---------------------------------
+mergeAlts :: [OutAlt] -> [OutAlt] -> [OutAlt]
+-- Merge preserving order; alternatives in the first arg
+-- shadow ones in the second
+mergeAlts [] as2 = as2
+mergeAlts as1 [] = as1
+mergeAlts (a1:as1) (a2:as2)
+ = case a1 `cmpAlt` a2 of
+ LT -> a1 : mergeAlts as1 (a2:as2)
+ EQ -> a1 : mergeAlts as1 as2 -- Discard a2
+ GT -> a2 : mergeAlts (a1:as1) as2
\end{code}
If so, then we can replace the case with one of the rhss.
+Further notes about case elimination
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider: test :: Integer -> IO ()
+ test = print
+
+Turns out that this compiles to:
+ Print.test
+ = \ eta :: Integer
+ eta1 :: State# RealWorld ->
+ case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
+ case hPutStr stdout
+ (PrelNum.jtos eta ($w[] @ Char))
+ eta1
+ of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}
+
+Notice the strange '<' which has no effect at all. This is a funny one.
+It started like this:
+
+f x y = if x < 0 then jtos x
+ else if y==0 then "" else jtos x
+
+At a particular call site we have (f v 1). So we inline to get
+
+ if v < 0 then jtos x
+ else if 1==0 then "" else jtos x
+
+Now simplify the 1==0 conditional:
+
+ if v<0 then jtos v else jtos v
+
+Now common-up the two branches of the case:
+
+ case (v<0) of DEFAULT -> jtos v
+
+Why don't we drop the case? Because it's strict in v. It's technically
+wrong to drop even unnecessary evaluations, and in practice they
+may be a result of 'seq' so we *definitely* don't want to drop those.
+I don't really know how to improve this situation.
+
\begin{code}
--------------------------------------------------
+-- 0. Check for empty alternatives
+--------------------------------------------------
+
+#ifdef DEBUG
+mkCase1 scrut case_bndr ty []
+ = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
+ returnSmpl scrut
+#endif
+
+--------------------------------------------------
-- 1. Eliminate the case altogether if poss
--------------------------------------------------
-mkCase1 scrut case_bndr [(con,bndrs,rhs)]
+mkCase1 scrut case_bndr ty [(con,bndrs,rhs)]
-- See if we can get rid of the case altogether
-- See the extensive notes on case-elimination above
-- mkCase made sure that if all the alternatives are equal,
-- Here we must *not* discard the case, because dataToTag# just fetches the tag from
-- the info pointer. So we'll be pedantic all the time, and see if that gives any
-- other problems
+-- Also we don't want to discard 'seq's
= tick (CaseElim case_bndr) `thenSmpl_`
returnSmpl (bindCaseBndr case_bndr scrut rhs)
-- 2. Identity case
--------------------------------------------------
-mkCase1 scrut case_bndr alts -- Identity case
+mkCase1 scrut case_bndr ty alts -- Identity case
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
returnSmpl (re_note scrut)
-- re_note wraps a coerce if it might be necessary
re_note scrut = case head alts of
- (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut
+ (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
other -> scrut
--------------------------------------------------
-- Catch-all
--------------------------------------------------
-mkCase1 scrut bndr alts = returnSmpl (Case scrut bndr alts)
+mkCase1 scrut bndr ty alts = returnSmpl (Case scrut bndr ty alts)
\end{code}
projects / ghc-hetmet.git / blobdiff