import PprCore
import CoreFVs
import CoreUtils
+import CoreArity ( etaExpand, exprEtaExpandArity )
import CoreUnfold
import Name
import Id
| Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
splitInlineCont cont@(Stop {}) = Just (mkBoringStop, cont)
splitInlineCont cont@(StrictBind {}) = Just (mkBoringStop, cont)
-splitInlineCont cont@(StrictArg {}) = Just (mkBoringStop, cont)
splitInlineCont _ = Nothing
+ -- NB: we dissolve an InlineMe in any strict context,
+ -- not just function aplication.
+ -- E.g. foldr k z (__inline_me (case x of p -> build ...))
+ -- Here we want to get rid of the __inline_me__ so we
+ -- can float the case, and see foldr/build
+ --
+ -- However *not* in a strict RHS, else we get
+ -- let f = __inline_me__ (\x. e) in ...f...
+ -- Now if f is guaranteed to be called, hence a strict binding
+ -- we don't thereby want to dissolve the __inline_me__; for
+ -- example, 'f' might be a wrapper, so we'd inline the worker
\end{code}
interestingCallContext cont
= interesting cont
where
- interestingCtxt = ArgCtxt False 2 -- Give *some* incentive!
-
interesting (Select _ bndr _ _ _)
- | isDeadBinder bndr = CaseCtxt
- | otherwise = interestingCtxt
+ | isDeadBinder bndr = CaseCtxt
+ | otherwise = ArgCtxt False 2 -- If the binder is used, this
+ -- is like a strict let
- interesting (ApplyTo {}) = interestingCtxt
- -- Can happen if we have (coerce t (f x)) y
- -- Perhaps interestingCtxt is a bit over-keen, but I've
- -- seen (coerce f) x, where f has an INLINE prag,
- -- So we have to give some motivation for inlining it
+ interesting (ApplyTo _ arg _ cont)
+ | isTypeArg arg = interesting cont
+ | otherwise = ValAppCtxt -- Can happen if we have (f Int |> co) y
+ -- If f has an INLINE prag we need to give it some
+ -- motivation to inline. See Note [Cast then apply]
+ -- in CoreUnfold
interesting (StrictArg _ cci _ _) = cci
interesting (StrictBind {}) = BoringCtxt
%************************************************************************
\begin{code}
-mkLam :: [OutBndr] -> OutExpr -> SimplM OutExpr
+mkLam :: SimplEnv -> [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 [] body
+mkLam _b [] body
= return body
-mkLam bndrs body
+mkLam _env bndrs body
= do { dflags <- getDOptsSmpl
; mkLam' dflags bndrs body }
where
| dopt Opt_DoLambdaEtaExpansion dflags,
any isRuntimeVar bndrs
- = do { body' <- tryEtaExpansion dflags body
+ = do { let body' = tryEtaExpansion dflags body
; return (mkLams bndrs body') }
| otherwise
actually computing the expansion.
\begin{code}
-tryEtaExpansion :: DynFlags -> OutExpr -> SimplM OutExpr
+tryEtaExpansion :: DynFlags -> OutExpr -> OutExpr
-- There is at least one runtime binder in the binders
-tryEtaExpansion dflags body = do
- us <- getUniquesM
- return (etaExpand fun_arity us body (exprType body))
+tryEtaExpansion dflags body
+ = etaExpand fun_arity body
where
fun_arity = exprEtaExpandArity dflags body
\end{code}
_ -> return [(DEFAULT, [], deflt_rhs)]
- | debugIsOn, isAlgTyCon tycon, [] <- tyConDataCons tycon
+ | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon)
+ -- This can legitimately happen for type families, so don't report that
= pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
- -- This can legitimately happen for type families
$ return [(DEFAULT, [], deflt_rhs)]
--------- Catch-all cases -----------