zapLamIdInfo, setOneShotLambda,
)
import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker,
- ArityInfo, setArityInfo, atLeastArity,
+ setArityInfo, unknownArity,
setUnfoldingInfo,
occInfo
)
-import Demand ( Demand, isStrict )
+import Demand ( isStrict )
import DataCon ( dataConNumInstArgs, dataConRepStrictness,
dataConSig, dataConArgTys
)
import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons,
callSiteInline
)
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial, exprIsConApp_maybe,
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsTrivial,
+ exprIsConApp_maybe, mkPiType,
exprType, coreAltsType, exprIsValue, idAppIsCheap,
- exprOkForSpeculation, etaReduceExpr,
+ exprOkForSpeculation,
mkCoerce, mkSCC, mkInlineMe, mkAltExpr
)
import Rules ( lookupRule )
import CostCentre ( currentCCS )
import Type ( mkTyVarTys, isUnLiftedType, seqType,
- mkFunTy, splitFunTy, splitTyConApp_maybe,
+ mkFunTy, splitTyConApp_maybe, tyConAppArgs,
funResultTy
)
-import Subst ( mkSubst, substTy, substExpr,
+import Subst ( mkSubst, substTy,
isInScope, lookupIdSubst, substIdInfo
)
import TyCon ( isDataTyCon, tyConDataConsIfAvailable )
Nothing -> rebuild (foldl (flip Lam) body' rev_bndrs) cont
where
- -- We don't use CoreUtils.etaReduceExpr, because we can be more
+ -- We don't use CoreUtils.etaReduce, because we can be more
-- efficient here: (a) we already have the binders, (b) we can do
-- the triviality test before computing the free vars
try_eta body | not opt_SimplDoEtaReduction = Nothing
= thing_inside
| exprIsTrivial new_rhs
- = completeTrivialBinding old_bndr new_bndr
- black_listed loop_breaker new_rhs
- thing_inside
+ -- We're looking at a binding with a trivial RHS, so
+ -- perhaps we can discard it altogether!
+ --
+ -- NB: a loop breaker never has postInlineUnconditionally 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: Even NOINLINEis 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.
+ = if must_keep_binding then -- Keep the binding
+ finally_bind_it unknownArity new_rhs
+ -- Arity doesn't really matter because for a trivial RHS
+ -- we will inline like crazy at call sites
+ -- If this turns out be false, we can easily compute arity
+ else -- Drop the binding
+ extendSubst old_bndr (DoneEx new_rhs) $
+ -- Use the substitution to make quite, quite sure that the substitution
+ -- will happen, since we are going to discard the binding
+ tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
+ thing_inside
| Note coercion@(Coerce _ inner_ty) inner_rhs <- new_rhs
+ -- [NB inner_rhs is guaranteed non-trivial by now]
-- x = coerce t e ==> c = e; x = inline_me (coerce t c)
-- Now x can get inlined, which moves the coercion
-- to the usage site. This is a bit like worker/wrapper stuff,
-- x = coerce T (I# 3)
-- get's w/wd to
-- c = I# 3
- -- x = coerce T $wx
+ -- x = coerce T c
-- This in turn means that
-- case (coerce Int x) of ...
-- will inline x.
-- get substituted away, but not if it's exported.)
= newId SLIT("c") inner_ty $ \ c_id ->
completeBinding c_id c_id top_lvl False inner_rhs $
- completeTrivialBinding old_bndr new_bndr black_listed loop_breaker
- (Note InlineMe (Note coercion (Var c_id))) $
+ completeBinding old_bndr new_bndr top_lvl black_listed
+ (Note InlineMe (Note coercion (Var c_id))) $
thing_inside
| otherwise
- = transformRhs new_rhs $ \ arity new_rhs' ->
- getSubst `thenSmpl` \ subst ->
- let
- -- We make new IdInfo for the new binder by starting from the old binder,
- -- doing appropriate substitutions.
- -- Then we add arity and unfolding info to get the new binder
- new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
- `setArityInfo` atLeastArity arity
-
- -- Add the unfolding *only* for non-loop-breakers
- -- Making loop breakers not have an unfolding at all
- -- means that we can avoid tests in exprIsConApp, for example.
- -- This is important: if exprIsConApp says 'yes' for a recursive
- -- thing, then we can get into an infinite loop
- info_w_unf | loop_breaker = new_bndr_info
- | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs'
-
- final_id = new_bndr `setIdInfo` info_w_unf
- in
- -- These seqs forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- final_id `seq`
- addLetBind (NonRec final_id new_rhs') $
- modifyInScope new_bndr final_id thing_inside
+ = transformRhs new_rhs finally_bind_it
where
- old_info = idInfo old_bndr
- occ_info = occInfo old_info
- loop_breaker = isLoopBreaker occ_info
+ old_info = idInfo old_bndr
+ occ_info = occInfo old_info
+ loop_breaker = isLoopBreaker occ_info
+ must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr
+
+ finally_bind_it arity_info new_rhs
+ = getSubst `thenSmpl` \ subst ->
+ let
+ -- We make new IdInfo for the new binder by starting from the old binder,
+ -- doing appropriate substitutions.
+ -- Then we add arity and unfolding info to get the new binder
+ new_bndr_info = substIdInfo subst old_info (idInfo new_bndr)
+ `setArityInfo` arity_info
+
+ -- Add the unfolding *only* for non-loop-breakers
+ -- Making loop breakers not have an unfolding at all
+ -- means that we can avoid tests in exprIsConApp, for example.
+ -- This is important: if exprIsConApp says 'yes' for a recursive
+ -- thing, then we can get into an infinite loop
+ info_w_unf | loop_breaker = new_bndr_info
+ | otherwise = new_bndr_info `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
+
+ final_id = new_bndr `setIdInfo` info_w_unf
+ in
+ -- These seqs forces the Id, and hence its IdInfo,
+ -- and hence any inner substitutions
+ final_id `seq`
+ addLetBind (NonRec final_id new_rhs) $
+ modifyInScope new_bndr final_id thing_inside
\end{code}
-\begin{code}
-completeTrivialBinding old_bndr new_bndr black_listed loop_breaker new_rhs thing_inside
- -- We're looking at a binding with a trivial RHS, so
- -- perhaps we can discard it altogether!
- --
- -- NB: a loop breaker never has postInlineUnconditionally True
- -- and non-loop-breakers only have *forward* references
- -- Hence, it's safe to discard the binding
- --
- -- NB: You might think that postInlineUnconditionally is an optimisation,
- -- but if we have
- -- let x = f Bool in (x, y)
- -- then because of the constructor, x will not be *inlined* in the pair,
- -- so the trivial binding will stay. But in this postInlineUnconditionally
- -- gag we use the *substitution* to substitute (f Bool) for x, and that *will*
- -- happen.
-
- -- 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: Even NOINLINEis 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.
-
- | not keep_binding -- Can discard binding, inlining everywhere
- = extendSubst old_bndr (DoneEx new_rhs) $
- tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
- thing_inside
-
- | otherwise -- We must keep the binding, but we may still inline
- = getSubst `thenSmpl` \ subst ->
- let
- new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr)
- final_id = new_bndr `setIdInfo` new_bndr_info
- in
- addLetBind (NonRec final_id new_rhs) $
- if dont_inline then
- modifyInScope new_bndr final_id thing_inside
- else
- extendSubst old_bndr (DoneEx new_rhs) thing_inside
- where
- dont_inline = black_listed || loop_breaker
- keep_binding = dont_inline || isExportedId old_bndr
-\end{code}
-
%************************************************************************
%* *
= getBlackList `thenSmpl` \ black_list_fn ->
getInScope `thenSmpl` \ in_scope ->
getContArgs var cont `thenSmpl` \ (args, call_cont, inline_call) ->
+ getDOptsSmpl `thenSmpl` \ dflags ->
let
black_listed = black_list_fn var
arg_infos = [ interestingArg in_scope arg subst
inline_cont | inline_call = discardInline cont
| otherwise = cont
- maybe_inline = callSiteInline black_listed inline_call occ
+ maybe_inline = callSiteInline dflags black_listed inline_call occ
var arg_infos interesting_cont
in
-- First, look for an inlining
(a) some might appear as a function argument, so we simply
replace static allocation with dynamic allocation:
l = <...>
- x = f x
+ x = f l
becomes
x = f <...>
simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
= mapSmpl simpl_alt alts
where
- inst_tys' = case splitTyConApp_maybe (idType case_bndr') of
- Just (tycon, inst_tys) -> inst_tys
+ inst_tys' = tyConAppArgs (idType case_bndr')
-- handled_cons is all the constructors that are dealt
-- with, either by being impossible, or by there being an alternative
`thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId SLIT("$j") (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
-
- -- Notice that we make the lambdas into one-shot-lambdas. The
+ newId SLIT("$j") (foldr mkPiType rhs_ty' final_bndrs') $ \ join_bndr ->
+ -- Notice the funky mkPiType. If the contructor has existentials
+ -- it's possible that the join point will be abstracted over
+ -- type varaibles as well as term variables.
+ -- Example: Suppose we have
+ -- data T = forall t. C [t]
+ -- Then faced with
+ -- case (case e of ...) of
+ -- C t xs::[t] -> rhs
+ -- We get the join point
+ -- let j :: forall t. [t] -> ...
+ -- j = /\t \xs::[t] -> rhs
+ -- in
+ -- case (case e of ...) of
+ -- C t xs::[t] -> j t xs
+
+ let
+ -- We make the lambdas into one-shot-lambdas. The
-- join point is sure to be applied at most once, and doing so
-- prevents the body of the join point being floated out by
-- the full laziness pass
- returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')],
+ really_final_bndrs = map one_shot final_bndrs'
+ one_shot v | isId v = setOneShotLambda v
+ | otherwise = v
+ in
+ returnSmpl ([NonRec join_bndr (mkLams really_final_bndrs rhs')],
(con, bndrs, mkApps (Var join_bndr) final_args))
\end{code}
projects / ghc-hetmet.git / blobdiff