import SimplEnv
import DynFlags ( SimplifierSwitch(..), SimplifierMode(..),
- DynFlag(..), dopt )
+ DynFlags, DynFlag(..), dopt )
import StaticFlags ( opt_UF_UpdateInPlace, opt_SimplNoPreInlining,
opt_RulesOff )
import CoreSyn
| 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
+ CoreExpr -- The argument
+ (Maybe SimplEnv) -- (Just se) => the arg is un-simplified and this is its subst-env
+ -- Nothing => the arg is already simplified; don't repeatedly simplify it!
+ SimplCont -- and its environment
| Select DupFlag
InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
- ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
data DupFlag = OkToDup | NoDup
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
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
-------------------
countArgs other = 0
-------------------
-pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
+pushContArgs ::[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)
+pushContArgs [] cont = cont
+pushContArgs (arg : args) cont = ApplyTo NoDup arg Nothing (pushContArgs args cont)
\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
+ -> ([(InExpr, Maybe SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
+ SimplCont) -- Remaining continuation
-- getContArgs id k = (args, k', inl)
-- args are the leading ApplyTo items in k
-- (i.e. outermost comes first)
stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
| otherwise = computed_stricts
in
- go [] stricts False orig_cont
+ go [] stricts orig_cont
where
----------------------------
-- Type argument
- go acc ss inl (ApplyTo _ arg@(Type _) se cont)
- = go ((arg,se,False) : acc) ss inl cont
+ go acc ss (ApplyTo _ arg@(Type _) se cont)
+ = go ((arg,se,False) : acc) ss 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
+ go acc (s:ss) (ApplyTo _ arg se cont)
+ = go ((arg,se,s) : acc) ss 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
-- 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)
+ go acc ss cont
+ | null ss && discardableCont cont = (reverse acc, discardCont cont)
+ | otherwise = (reverse acc, cont)
----------------------------
vanilla_stricts, computed_stricts :: [Bool]
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 (ArgOf {}) = 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
interestingArgContext fn cont
= idHasRules fn || go cont
where
- go (InlinePlease c) = go c
go (Select {}) = False
go (ApplyTo {}) = False
go (ArgOf {}) = True
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
| 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 work-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
| dopt Opt_DoLambdaEtaExpansion dflags,
any isRuntimeVar bndrs
- = tryEtaExpansion body `thenSmpl` \ body' ->
+ = tryEtaExpansion dflags body `thenSmpl` \ body' ->
returnSmpl (emptyFloats env, mkLams bndrs body')
{- Sept 01: I'm experimenting with getting the
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}
projects / ghc-hetmet.git / blobdiff