\begin{code}
module SimplUtils (
- mkLam, mkCase,
+ -- Rebuilding
+ mkLam, mkCase,
-- Inlining,
- preInlineUnconditionally, postInlineUnconditionally, activeInline, activeRule,
- inlineMode,
+ preInlineUnconditionally, postInlineUnconditionally,
+ activeInline, activeRule, inlineMode,
-- The continuation type
SimplCont(..), DupFlag(..), LetRhsFlag(..),
- contIsDupable, contResultType,
- countValArgs, countArgs, pushContArgs,
- mkBoringStop, mkRhsStop, contIsRhs, contIsRhsOrArg,
- getContArgs, interestingCallContext, interestingArg, isStrictType
+ contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs,
+ countValArgs, countArgs,
+ mkBoringStop, mkLazyArgStop, mkRhsStop, contIsRhsOrArg,
+ interestingCallContext, interestingArgContext,
+ interestingArg, isStrictBndr, mkArgInfo
) where
#include "HsVersions.h"
import SimplEnv
-import DynFlags ( SimplifierSwitch(..), SimplifierMode(..),
- DynFlag(..), dopt )
-import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
- opt_RulesOff )
+import DynFlags
+import StaticFlags
import CoreSyn
-import CoreFVs ( exprFreeVars )
-import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
- etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
- findDefault, exprOkForSpeculation, exprIsHNF, mergeAlts
- )
-import Literal ( mkStringLit )
-import CoreUnfold ( smallEnoughToInline )
-import MkId ( eRROR_ID )
-import Id ( idType, isDataConWorkId, idOccInfo, isDictId,
- isDeadBinder, idNewDemandInfo, isExportedId,
- idUnfolding, idNewStrictness, idInlinePragma,
- )
-import NewDemand ( isStrictDmd, isBotRes, splitStrictSig )
+import PprCore
+import CoreFVs
+import CoreUtils
+import Literal
+import CoreUnfold
+import MkId
+import Id
+import NewDemand
import SimplMonad
-import Type ( Type, splitFunTys, dropForAlls, isStrictType,
- splitTyConApp_maybe, tyConAppArgs
- )
-import TyCon ( tyConDataCons_maybe )
-import DataCon ( dataConRepArity )
+import Type
+import TyCon
+import DataCon
import VarSet
-import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
- Activation, isAlwaysActive, isActive )
-import Util ( lengthExceeds )
+import BasicTypes
+import Util
import Outputable
\end{code}
%************************************************************************
%* *
-\subsection{The continuation data type}
+ The SimplCont type
%* *
%************************************************************************
+A SimplCont allows the simplifier to traverse the expression in a
+zipper-like fashion. The SimplCont represents the rest of the expression,
+"above" the point of interest.
+
+You can also think of a SimplCont as an "evaluation context", using
+that term in the way it is used for operational semantics. This is the
+way I usually think of it, For example you'll often see a syntax for
+evaluation context looking like
+ C ::= [] | C e | case C of alts | C `cast` co
+That's the kind of thing we are doing here, and I use that syntax in
+the comments.
+
+
+Key points:
+ * A SimplCont describes a *strict* context (just like
+ evaluation contexts do). E.g. Just [] is not a SimplCont
+
+ * A SimplCont describes a context that *does not* bind
+ any variables. E.g. \x. [] is not a SimplCont
+
\begin{code}
-data SimplCont -- Strict contexts
- = Stop OutType -- Type of the result
- LetRhsFlag
- Bool -- True <=> This is the RHS of a thunk whose type suggests
- -- that update-in-place would be possible
- -- (This makes the inliner a little keener.)
-
- | CoerceIt OutType -- The To-type, simplified
- SimplCont
-
- | InlinePlease -- This continuation makes a function very
- SimplCont -- keen to inline itelf
-
- | ApplyTo DupFlag
- InExpr SimplEnv -- The argument, as yet unsimplified,
- SimplCont -- and its environment
-
- | Select DupFlag
- InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
- SimplCont
-
- | ArgOf LetRhsFlag -- An arbitrary strict context: the argument
- -- of a strict function, or a primitive-arg fn
- -- or a PrimOp
- -- 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
+data SimplCont
+ = Stop -- An empty context, or hole, []
+ OutType -- Type of the result
+ LetRhsFlag
+ Bool -- True <=> There is something interesting about
+ -- the context, and hence the inliner
+ -- should be a bit keener (see interestingCallContext)
+ -- Two cases:
+ -- (a) This is the RHS of a thunk whose type suggests
+ -- that update-in-place would be possible
+ -- (b) This is an argument of a function that has RULES
+ -- Inlining the call might allow the rule to fire
+
+ | CoerceIt -- C `cast` co
+ OutCoercion -- The coercion simplified
+ SimplCont
+
+ | ApplyTo -- C arg
+ DupFlag
+ InExpr SimplEnv -- The argument and its static env
+ SimplCont
+
+ | Select -- case C of alts
+ DupFlag
+ InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
+ SimplCont
+
+ -- The two strict forms have no DupFlag, because we never duplicate them
+ | StrictBind -- (\x* \xs. e) C
+ InId [InBndr] -- let x* = [] in e
+ InExpr SimplEnv -- is a special case
+ SimplCont
+
+ | StrictArg -- e C
+ OutExpr OutType -- e and its type
+ (Bool,[Bool]) -- Whether the function at the head of e has rules,
+ SimplCont -- plus strictness flags for further args
data LetRhsFlag = AnArg -- It's just an argument not a let RHS
| AnRhs -- It's the RHS of a let (so please float lets out of big lambdas)
instance Outputable SimplCont where
ppr (Stop ty is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs) <+> ppr ty
- ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
- ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
+ ppr (ApplyTo dup arg se cont) = ((ptext SLIT("ApplyTo") <+> ppr dup <+> pprParendExpr arg) $$
+ nest 2 (pprSimplEnv se)) $$ ppr cont
+ ppr (StrictBind b _ _ _ cont) = (ptext SLIT("StrictBind") <+> ppr b) $$ ppr cont
+ ppr (StrictArg f _ _ cont) = (ptext SLIT("StrictArg") <+> ppr f) $$ ppr cont
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
+ (nest 4 (ppr alts $$ pprSimplEnv se)) $$ ppr cont
+ ppr (CoerceIt co cont) = (ptext SLIT("CoerceIt") <+> ppr co) $$ ppr cont
data DupFlag = OkToDup | NoDup
ppr NoDup = ptext SLIT("nodup")
+
-------------------
-mkBoringStop, mkRhsStop :: OutType -> SimplCont
-mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
-mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty AnArg False
-contIsRhs :: SimplCont -> Bool
-contIsRhs (Stop _ AnRhs _) = True
-contIsRhs (ArgOf AnRhs _ _ _) = True
-contIsRhs other = False
+mkLazyArgStop :: OutType -> Bool -> SimplCont
+mkLazyArgStop ty has_rules = Stop ty AnArg (canUpdateInPlace ty || has_rules)
+
+mkRhsStop :: OutType -> SimplCont
+mkRhsStop ty = Stop ty AnRhs (canUpdateInPlace ty)
contIsRhsOrArg (Stop _ _ _) = True
-contIsRhsOrArg (ArgOf _ _ _ _) = True
+contIsRhsOrArg (StrictBind {}) = True
+contIsRhsOrArg (StrictArg {}) = True
contIsRhsOrArg other = False
-------------------
contIsDupable (ApplyTo OkToDup _ _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
contIsDupable (CoerceIt _ cont) = contIsDupable cont
-contIsDupable (InlinePlease cont) = contIsDupable cont
contIsDupable other = False
-------------------
-discardableCont :: SimplCont -> Bool
-discardableCont (Stop _ _ _) = False
-discardableCont (CoerceIt _ cont) = discardableCont cont
-discardableCont (InlinePlease cont) = discardableCont cont
-discardableCont other = True
-
-discardCont :: SimplCont -- A continuation, expecting
- -> SimplCont -- Replace the continuation with a suitable coerce
-discardCont cont = case cont of
- Stop to_ty is_rhs _ -> cont
- other -> CoerceIt to_ty (mkBoringStop to_ty)
- where
- to_ty = contResultType cont
+contIsTrivial :: SimplCont -> Bool
+contIsTrivial (Stop _ _ _) = True
+contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont
+contIsTrivial (CoerceIt _ cont) = contIsTrivial cont
+contIsTrivial other = False
-------------------
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
+contResultType (Stop to_ty _ _) = to_ty
+contResultType (StrictArg _ _ _ cont) = contResultType cont
+contResultType (StrictBind _ _ _ _ cont) = contResultType cont
+contResultType (ApplyTo _ _ _ cont) = contResultType cont
+contResultType (CoerceIt _ cont) = contResultType cont
+contResultType (Select _ _ _ _ cont) = contResultType cont
-------------------
countValArgs :: 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)
+contArgs :: SimplCont -> ([OutExpr], SimplCont)
+-- Uses substitution to turn each arg into an OutExpr
+contArgs cont = go [] cont
+ where
+ go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
+ go args cont = (reverse args, cont)
+
+dropArgs :: Int -> SimplCont -> SimplCont
+dropArgs 0 cont = cont
+dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
+dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other)
\end{code}
\begin{code}
-getContArgs :: SwitchChecker
- -> OutId -> SimplCont
- -> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
- SimplCont, -- Remaining continuation
- Bool) -- Whether we came across an InlineCall
--- getContArgs id k = (args, k', inl)
--- args are the leading ApplyTo items in k
--- (i.e. outermost comes first)
--- augmented with demand info from the functionn
-getContArgs chkr fun orig_cont
- = let
- -- Ignore strictness info if the no-case-of-case
- -- flag is on. Strictness changes evaluation order
- -- and that can change full laziness
- stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
- | otherwise = computed_stricts
- in
- go [] stricts False orig_cont
- where
- ----------------------------
-
- -- Type argument
- go acc ss inl (ApplyTo _ arg@(Type _) se cont)
- = go ((arg,se,False) : acc) ss inl cont
- -- NB: don't bother to instantiate the function type
-
- -- Value argument
- go acc (s:ss) inl (ApplyTo _ arg se cont)
- = go ((arg,se,s) : acc) ss inl cont
-
- -- An Inline continuation
- go acc ss inl (InlinePlease cont)
- = go acc ss True cont
-
- -- We're run out of arguments, or else we've run out of demands
- -- The latter only happens if the result is guaranteed bottom
- -- This is the case for
- -- * case (error "hello") of { ... }
- -- * (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)
-
- ----------------------------
- vanilla_stricts, computed_stricts :: [Bool]
- vanilla_stricts = repeat False
- computed_stricts = zipWith (||) fun_stricts arg_stricts
-
- ----------------------------
- (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 splitFunTys*IgnoringForAlls*
-
- ----------------------------
- -- If fun_stricts is finite, it means the function returns bottom
- -- after that number of value args have been consumed
- -- Otherwise it's infinite, extended with False
- fun_stricts
- = case splitStrictSig (idNewStrictness fun) of
- (demands, result_info)
- | not (demands `lengthExceeds` countValArgs orig_cont)
- -> -- Enough args, use the strictness given.
- -- For bottoming functions we used to pretend that the arg
- -- is lazy, so that we don't treat the arg as an
- -- interesting context. This avoids substituting
- -- top-level bindings for (say) strings into
- -- calls to error. But now we are more careful about
- -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
- if isBotRes result_info then
- map isStrictDmd demands -- Finite => result is bottom
- else
- map isStrictDmd demands ++ vanilla_stricts
-
- other -> vanilla_stricts -- Not enough args, or no strictness
-
--------------------
interestingArg :: OutExpr -> Bool
-- An argument is interesting if it has *some* structure
-- We are here trying to avoid unfolding a function that
interestingArg (Type _) = False
interestingArg (App fn (Type _)) = interestingArg fn
interestingArg (Note _ a) = interestingArg a
+
+-- Idea (from Sam B); I'm not sure if it's a good idea, so commented out for now
+-- interestingArg expr | isUnLiftedType (exprType expr)
+-- -- Unlifted args are only ever interesting if we know what they are
+-- = case expr of
+-- Lit lit -> True
+-- _ -> False
+
interestingArg other = True
-- Consider let x = 3 in f x
-- The substitution will contain (x -> ContEx 3), and we want to
-- that x is not interesting (assuming y has no unfolding)
\end{code}
+
Comment about interestingCallContext
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to avoid inlining an expression where there can't possibly be
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 (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
- interesting (ArgOf _ _ _ _) = some_val_args
- interesting (Stop ty _ upd_in_place) = some_val_args && upd_in_place
+ interesting (StrictArg {}) = some_val_args
+ interesting (StrictBind {}) = some_val_args -- ??
+ interesting (Stop ty _ interesting) = some_val_args && interesting
interesting (CoerceIt _ cont) = interesting cont
-- If this call is the arg of a strict function, the context
-- is a bit interesting. If we inline here, we may get useful
-------------------
+mkArgInfo :: Id
+ -> Int -- Number of value args
+ -> SimplCont -- Context of the cal
+ -> (Bool, [Bool]) -- Arg info
+-- The arg info consists of
+-- * A Bool indicating if the function has rules (recursively)
+-- * A [Bool] indicating strictness for each arg
+-- The [Bool] is usually infinite, but if it is finite it
+-- guarantees that the function diverges after being given
+-- that number of args
+
+mkArgInfo fun n_val_args call_cont
+ = (interestingArgContext fun call_cont, fun_stricts)
+ where
+ vanilla_stricts, fun_stricts :: [Bool]
+ vanilla_stricts = repeat False
+
+ fun_stricts
+ = case splitStrictSig (idNewStrictness fun) of
+ (demands, result_info)
+ | not (demands `lengthExceeds` n_val_args)
+ -> -- Enough args, use the strictness given.
+ -- For bottoming functions we used to pretend that the arg
+ -- is lazy, so that we don't treat the arg as an
+ -- interesting context. This avoids substituting
+ -- top-level bindings for (say) strings into
+ -- calls to error. But now we are more careful about
+ -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
+ if isBotRes result_info then
+ map isStrictDmd demands -- Finite => result is bottom
+ else
+ map isStrictDmd demands ++ vanilla_stricts
+
+ other -> vanilla_stricts -- Not enough args, or no strictness
+
+interestingArgContext :: Id -> SimplCont -> Bool
+-- If the argument has form (f x y), where x,y are boring,
+-- and f is marked INLINE, then we don't want to inline f.
+-- But if the context of the argument is
+-- g (f x y)
+-- where g has rules, then we *do* want to inline f, in case it
+-- exposes a rule that might fire. Similarly, if the context is
+-- h (g (f x x))
+-- where h has rules, then we do want to inline f.
+-- The interesting_arg_ctxt flag makes this happen; if it's
+-- set, the inliner gets just enough keener to inline f
+-- regardless of how boring f's arguments are, if it's marked INLINE
+--
+-- The alternative would be to *always* inline an INLINE function,
+-- regardless of how boring its context is; but that seems overkill
+-- For example, it'd mean that wrapper functions were always inlined
+interestingArgContext fn cont
+ = idHasRules fn || go cont
+ where
+ go (Select {}) = False
+ go (ApplyTo {}) = False
+ go (StrictArg {}) = True
+ go (StrictBind {}) = False -- ??
+ go (CoerceIt _ c) = go c
+ go (Stop _ _ interesting) = interesting
+
+-------------------
canUpdateInPlace :: Type -> Bool
-- Consider let x = <wurble> in ...
-- If <wurble> returns an explicit constructor, we might be able
==> ...(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
+The no-inlining 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
story for now.
\begin{code}
-postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -> OccInfo -> OutExpr -> Unfolding -> Bool
+postInlineUnconditionally
+ :: SimplEnv -> TopLevelFlag
+ -> InId -- The binder (an OutId would be fine too)
+ -> OccInfo -- From the InId
+ -> OutExpr
+ -> Unfolding
+ -> Bool
postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
| not active = False
- | isLoopBreaker occ_info = False
+ | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, dont' inline
+ -- because it might be referred to "earlier"
| 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
+ -- The point of examining occ_info 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
+ OneOcc in_lam one_br int_cxt -- OneOcc => no code-duplication issue
+ -> 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).
+ -- NB: Do NOT inline arbitrarily big things, even if one_br is True
+ -- Reason: doing so risks exponential behaviour. We simplify a big
+ -- expression, inline it, and simplify it again. But if the
+ -- very same thing happens in the big expression, we get
+ -- exponential cost!
+ -- PRINCIPLE: when we've already simplified an expression once,
+ -- make sure that we only inline it if it's reasonably small.
&& ((isNotTopLevel top_lvl && not in_lam) ||
-- But outside a lambda, we want to be reasonably aggressive
-- int_cxt to prevent us inlining inside a lambda without some
-- good reason. See the notes on int_cxt in preInlineUnconditionally
+ IAmDead -> True -- This happens; for example, the case_bndr during case of
+ -- known constructor: case (a,b) of x { (p,q) -> ... }
+ -- Here x isn't mentioned in the RHS, so we don't want to
+ -- create the (dead) let-binding let x = (a,b) in ...
+
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
+
+-- Here's an example that we don't handle well:
+-- let f = if b then Left (\x.BIG) else Right (\y.BIG)
+-- in \y. ....case f of {...} ....
+-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
+-- But
+-- * We can't preInlineUnconditionally because that woud invalidate
+-- the occ info for b.
+-- * We can't postInlineUnconditionally because the RHS is big, and
+-- that risks exponential behaviour
+-- * We can't call-site inline, because the rhs is big
+-- Alas!
+
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
+activeInline :: SimplEnv -> OutId -> Bool
+activeInline env id
= case getMode env of
- SimplGently -> isOneOcc occ && isAlwaysActive prag
+ SimplGently -> False
-- 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
-- to work in Template Haskell when simplifying
-- splices, so we get simpler code for literal strings
SimplPhase n -> Just (isActive n)
-\end{code}
+\end{code}
%************************************************************************
%* *
-\subsection{Rebuilding a lambda}
+ Rebuilding a lambda
%* *
%************************************************************************
\begin{code}
-mkLam :: SimplEnv -> [OutBinder] -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
+mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr
+-- mkLam tries three things
+-- a) eta reduction, if that gives a trivial expression
+-- b) eta expansion [only if there are some value lambdas]
+
+mkLam bndrs body
+ = do { dflags <- getDOptsSmpl
+ ; mkLam' dflags bndrs body }
+ where
+ mkLam' dflags bndrs body
+ | dopt Opt_DoEtaReduction dflags,
+ Just etad_lam <- tryEtaReduce bndrs body
+ = do { tick (EtaReduction (head bndrs))
+ ; return etad_lam }
+
+ | dopt Opt_DoLambdaEtaExpansion dflags,
+ any isRuntimeVar bndrs
+ = do { body' <- tryEtaExpansion dflags body
+ ; return (mkLams bndrs body') }
+
+ | otherwise
+ = returnSmpl (mkLams bndrs body)
\end{code}
-Try three things
- a) eta reduction, if that gives a trivial expression
- b) eta expansion [only if there are some value lambdas]
- c) floating lets out through big lambdas
- [only if all tyvar lambdas, and only if this lambda
- is the RHS of a let]
-
-\begin{code}
-mkLam env bndrs body cont
- = 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')
+-- c) floating lets out through big lambdas
+-- [only if all tyvar lambdas, and only if this lambda
+-- is the RHS of a let]
{- 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)
-\end{code}
-
%************************************************************************
%* *
to avoid allocating this thing altogether
\begin{code}
-tryEtaReduce :: [OutBinder] -> OutExpr -> Maybe OutExpr
+tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
tryEtaReduce bndrs body
-- We don't use CoreUtils.etaReduce, because we can be more
-- efficient here:
actually computing the expansion.
\begin{code}
-tryEtaExpansion :: OutExpr -> SimplM OutExpr
+tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
-- There is at least one runtime binder in the binders
-tryEtaExpansion body
+tryEtaExpansion dflags body
= getUniquesSmpl `thenSmpl` \ us ->
returnSmpl (etaExpand fun_arity us body (exprType body))
where
- fun_arity = exprEtaExpandArity body
+ fun_arity = exprEtaExpandArity dflags body
\end{code}
%* *
%************************************************************************
+
mkCase puts a case expression back together, trying various transformations first.
\begin{code}
other -> ...(case x of
0# -> ...
other -> ...) ...
-\end{code}
+\end{verbatim}
Here the inner case can be eliminated. This really only shows up in
eliminating error-checking code.
mkCase1 scrut case_bndr ty alts -- Identity case
| all identity_alt alts
= tick (CaseIdentity case_bndr) `thenSmpl_`
- returnSmpl (re_note scrut)
+ returnSmpl (re_cast scrut)
where
- identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args
+ identity_alt (con, args, rhs) = de_cast rhs `cheapEqExpr` mk_id_rhs con args
- identity_rhs (DataAlt con) args = mkConApp con (arg_tys ++ map varToCoreExpr args)
- identity_rhs (LitAlt lit) _ = Lit lit
- identity_rhs DEFAULT _ = Var case_bndr
+ mk_id_rhs (DataAlt con) args = mkConApp con (arg_tys ++ varsToCoreExprs args)
+ mk_id_rhs (LitAlt lit) _ = Lit lit
+ mk_id_rhs DEFAULT _ = Var case_bndr
arg_tys = map Type (tyConAppArgs (idType case_bndr))
-- We've seen this:
- -- case coerce T e of x { _ -> coerce T' x }
- -- And we definitely want to eliminate this case!
- -- So we throw away notes from the RHS, and reconstruct
- -- (at least an approximation) at the other end
- de_note (Note _ e) = de_note e
- de_note e = e
-
- -- re_note wraps a coerce if it might be necessary
- re_note scrut = case head alts of
- (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut
- other -> scrut
+ -- case e of x { _ -> x `cast` c }
+ -- And we definitely want to eliminate this case, to give
+ -- e `cast` c
+ -- So we throw away the cast from the RHS, and reconstruct
+ -- it at the other end. All the RHS casts must be the same
+ -- if (all identity_alt alts) holds.
+ --
+ -- Don't worry about nested casts, because the simplifier combines them
+ de_cast (Cast e _) = e
+ de_cast e = e
+
+ re_cast scrut = case head alts of
+ (_,_,Cast _ co) -> Cast scrut co
+ other -> scrut
+
--------------------------------------------------
projects / ghc-hetmet.git / blobdiff