-import SimplUtils ( mkCase, mkLam, newId, prepareAlts,
- simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr,
+import SimplEnv
+import SimplUtils ( mkCase, mkLam, prepareAlts,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
SimplCont(..), DupFlag(..), LetRhsFlag(..),
mkRhsStop, mkBoringStop, pushContArgs,
contResultType, countArgs, contIsDupable, contIsRhsOrArg,
- getContArgs, interestingCallContext, interestingArg, isStrictType
+ getContArgs, interestingCallContext, interestingArg, isStrictType,
+ preInlineUnconditionally, postInlineUnconditionally,
+ inlineMode, activeInline, activeRule
)
import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
)
import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
import IdInfo ( OccInfo(..), isLoopBreaker,
setArityInfo, zapDemandInfo,
setUnfoldingInfo,
import IdInfo ( OccInfo(..), isLoopBreaker,
setArityInfo, zapDemandInfo,
setUnfoldingInfo,
-import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon, dataConResTy )
+import DataCon ( dataConTyCon, dataConRepStrictness, isVanillaDataCon )
import TyCon ( tyConArity )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
import TyCon ( tyConArity )
import CoreSyn
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprOkForSpeculation, exprArity,
mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
)
exprOkForSpeculation, exprArity,
mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
)
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
import BasicTypes ( isMarkedStrict )
import CostCentre ( currentCCS )
import Type ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
- splitFunTy_maybe, splitFunTy, coreEqType, substTy,
- mkTyVarTys, mkTyConApp
+ splitFunTy_maybe, splitFunTy, coreEqType
-import VarEnv ( elemVarEnv )
-import Subst ( SubstResult(..), emptySubst, substExpr,
- substId, simplIdInfo )
+import VarEnv ( elemVarEnv, emptyVarEnv )
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec
)
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
RecFlag(..), isNonRec
)
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) ->
freeTick SimplifierDone `thenSmpl_`
returnSmpl (floatBinds floats)
- | preInlineUnconditionally env NotTopLevel bndr
- = tick (PreInlineUnconditionally bndr) `thenSmpl_`
- thing_inside (extendIdSubst env bndr (ContEx (getSubst rhs_se) rhs))
+ = simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside
+simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside
+ | preInlineUnconditionally env NotTopLevel bndr rhs
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ thing_inside (extendIdSubst env bndr (mkContEx rhs_se rhs))
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence info in the substitution
simplLetBndr env bndr `thenSmpl` \ (env, bndr1) ->
= -- Don't use simplBinder because that doesn't keep
-- fragile occurrence info in the substitution
simplLetBndr env bndr `thenSmpl` \ (env, bndr1) ->
let
-- simplLetBndr doesn't deal with the IdInfo, so we must
-- do so here (c.f. simplLazyBind)
let
-- simplLetBndr doesn't deal with the IdInfo, so we must
-- do so here (c.f. simplLazyBind)
- completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
+ if needsCaseBinding bndr_ty rhs1
+ then
+ thing_inside env2 `thenSmpl` \ (floats, body) ->
+ returnSmpl (emptyFloats env2, Case rhs1 bndr2 (exprType body)
+ [(DEFAULT, [], wrapFloats floats body)])
+ else
+ completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
| otherwise -- Normal, lazy case
= -- Don't use simplBinder because that doesn't keep
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
simplLazyBind env NotTopLevel NonRecursive
bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) ->
addFloats env floats thing_inside
-- because quotInt# can fail.
= simplBinder env bndr `thenSmpl` \ (env, bndr') ->
thing_inside env `thenSmpl` \ (floats, body) ->
-- because quotInt# can fail.
= simplBinder env bndr `thenSmpl` \ (env, bndr') ->
thing_inside env `thenSmpl` \ (floats, body) ->
let body' = wrapFloats floats body in
returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')])
let body' = wrapFloats floats body in
returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')])
-- 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
-- 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
-- Similarly, single occurrences can be inlined vigourously
-- e.g. case (f x, g y) of (a,b) -> ....
-- If a,b occur once we can avoid constructing the let binding for them.
-- Similarly, single occurrences can be inlined vigourously
-- e.g. case (f x, g y) of (a,b) -> ....
-- If a,b occur once we can avoid constructing the let binding for them.
- | preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
- = tick (PreInlineUnconditionally bndr) `thenSmpl_`
- returnSmpl (emptyFloats env, extendIdSubst env bndr (ContEx (getSubst env) rhs))
+ | preInlineUnconditionally env top_lvl bndr rhs -- Check for unconditional inline
+ = tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ returnSmpl (emptyFloats env, extendIdSubst env bndr (mkContEx env rhs))
env1 = modifyInScope env bndr2 bndr2
rhs_env = setInScope rhs_se env1
is_top_level = isTopLevel top_lvl
env1 = modifyInScope env bndr2 bndr2
rhs_env = setInScope rhs_se env1
is_top_level = isTopLevel top_lvl
if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
completeLazyBind env1 top_lvl bndr bndr2 rhs2
if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case
completeLazyBind env1 top_lvl bndr bndr2 rhs2
-- because that causes a strictness bug.
-- x = let y* = E in case (scc y) of { T -> F; F -> T}
-- The case expression is 'cheap', but it's wrong to transform to
-- y* = E; x = case (scc y) of {...}
-- Either we must be careful not to float demanded non-values, or
-- because that causes a strictness bug.
-- x = let y* = E in case (scc y) of { T -> F; F -> T}
-- The case expression is 'cheap', but it's wrong to transform to
-- y* = E; x = case (scc y) of {...}
-- Either we must be careful not to float demanded non-values, or
- -- we must use exprIsValue for the test, which ensures that the
- -- thing is non-strict. So exprIsValue => bindings are non-strict
+ -- we must use exprIsHNF for the test, which ensures that the
+ -- thing is non-strict. So exprIsHNF => bindings are non-strict
-- I think. The WARN below tests for this.
--
-- We use exprIsTrivial here because we want to reveal lone variables.
-- E.g. let { x = letrec { y = E } in y } in ...
-- Here we definitely want to float the y=E defn.
-- I think. The WARN below tests for this.
--
-- We use exprIsTrivial here because we want to reveal lone variables.
-- E.g. let { x = letrec { y = E } in y } in ...
-- Here we definitely want to float the y=E defn.
--
-- Again, the floated binding can't be strict; if it's recursive it'll
-- be non-strict; if it's non-recursive it'd be inlined.
--
-- Again, the floated binding can't be strict; if it's recursive it'll
-- be non-strict; if it's non-recursive it'd be inlined.
-- (as usual) use the in-scope-env from the floats
completeLazyBind env top_lvl old_bndr new_bndr new_rhs
-- (as usual) use the in-scope-env from the floats
completeLazyBind env top_lvl old_bndr new_bndr new_rhs
= -- Drop the binding
tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
= -- Drop the binding
tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
-- After inling f at some of its call sites the original binding may
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
-- After inling f at some of its call sites the original binding may
-- (for example) be no longer strictly demanded.
-- The solution here is a bit ad hoc...
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
final_info | loop_breaker = new_bndr_info
| isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding
final_info | loop_breaker = new_bndr_info
| isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf
loop_breaker = isLoopBreaker occ_info
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
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
where
simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr env expr = simplExprC env expr (mkBoringStop expr_ty')
where
-- The type in the Stop continuation, expr_ty', is usually not used
-- It's only needed when discarding continuations after finding
-- a function that returns bottom.
-- The type in the Stop continuation, expr_ty', is usually not used
-- It's only needed when discarding continuations after finding
-- a function that returns bottom.
simplExprF env (Case scrut bndr case_ty alts) cont
| not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
= -- Simplify the scrutinee with a Select continuation
simplExprF env (Case scrut bndr case_ty alts) cont
| not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
= -- Simplify the scrutinee with a Select continuation
+ addCoerce s1 k1 cont -- Drop redundant coerces. This can happen if a polymoprhic
+ -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the
+ -- two are the same. This happens a lot in Happy-generated parsers
+ | s1 `coreEqType` k1 = cont
+
- | t1 `coreEqType` k1 = cont -- The coerces cancel out
- | otherwise = CoerceIt t1 cont -- They don't cancel, but
- -- the inner one is redundant
+ | t1 `coreEqType` k1 = cont -- The coerces cancel out
+ | otherwise = CoerceIt t1 cont -- They don't cancel, but
+ -- the inner one is redundant
addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
| not (isTypeArg arg), -- This whole case only works for value args
addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
| not (isTypeArg arg), -- This whole case only works for value args
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
- = case substId (getSubst env) var of
- DoneEx e -> simplExprF (zapSubstEnv env) e cont
- ContEx se e -> simplExprF (setSubstEnv env se) e cont
- DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont
+ = case substId env var of
+ DoneEx e -> simplExprF (zapSubstEnv env) e cont
+ ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
+ DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
-- Note [zapSubstEnv]
-- The template is already simplified, so don't re-substitute.
-- This is VITAL. Consider
+ (if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "Inlining done" (vcat [
+ text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
+ text "Inlined fn: " <+> ppr unfolding,
+ text "Cont: " <+> ppr call_cont])
+ else
+ id) $
-- The new subst_env is in place
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
-- The new subst_env is in place
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
addFloats env floats $ \ env ->
simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
-- Deal with the case alternatives
simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr') ->
-- Deal with the case alternatives
- = mapSmpl simpl_alt alts
+ = do { mb_alts <- mapSmpl simpl_alt alts
+ ; return [alt' | Just (_, alt') <- mb_alts] }
+ -- Filter out the alternatives that are inaccessible
-- Simplify an alternative, returning the type refinement for the
-- alternative, if the alternative does any refinement at all
-- Simplify an alternative, returning the type refinement for the
-- alternative, if the alternative does any refinement at all
simplAlt env handled_cons case_bndr' (DEFAULT, bndrs, rhs) cont'
= ASSERT( null bndrs )
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
simplAlt env handled_cons case_bndr' (DEFAULT, bndrs, rhs) cont'
= ASSERT( null bndrs )
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Nothing, (DEFAULT, [], rhs'))
+ returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs')))
where
env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons)
-- Record the constructors that the case-binder *can't* be.
where
env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons)
-- Record the constructors that the case-binder *can't* be.
simplAlt env handled_cons case_bndr' (LitAlt lit, bndrs, rhs) cont'
= ASSERT( null bndrs )
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
simplAlt env handled_cons case_bndr' (LitAlt lit, bndrs, rhs) cont'
= ASSERT( null bndrs )
simplExprC env' rhs cont' `thenSmpl` \ rhs' ->
- returnSmpl (Nothing, (LitAlt lit, [], rhs'))
+ returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs')))
- returnSmpl (Nothing, (DataAlt con, vs', rhs'))
+ returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs')))
| otherwise -- GADT case
= let
(tvs,ids) = span isTyVar vs
in
simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
| otherwise -- GADT case
= let
(tvs,ids) = span isTyVar vs
in
simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
- let
- pat_res_ty = dataConResTy con (mkTyVarTys tvs')
- tv_subst = getTvSubst env1
- in
- case coreRefineTys tvs' tv_subst pat_res_ty (idType case_bndr') of {
- Nothing -- Dead code; for now, I'm just going to put in an
- -- error case so I can see them
+ case coreRefineTys (getInScope env1) con tvs' (idType case_bndr') of {
+ Nothing -- Inaccessible
+ | opt_PprStyle_Debug -- Hack: if debugging is on, generate an error case
+ -- so we can see it
Lit (mkStringLit "Impossible alternative (GADT)")]
in
simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
Lit (mkStringLit "Impossible alternative (GADT)")]
in
simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
- returnSmpl (Nothing, (DataAlt con, tvs' ++ ids', rhs')) ;
+ returnSmpl (Just (emptyVarEnv, (DataAlt con, tvs' ++ ids', rhs')))
-- Simplify the Ids in the refined environment, so their types
-- reflect the refinement. Usually this doesn't matter, but it helps
-- in mkDupableAlt, when we want to float a lambda that uses these binders
-- Simplify the Ids in the refined environment, so their types
-- reflect the refinement. Usually this doesn't matter, but it helps
-- in mkDupableAlt, when we want to float a lambda that uses these binders
in
simplBinders env2 (add_evals con ids) `thenSmpl` \ (env3, ids') ->
let unf = mkUnfolding False con_app
in
simplBinders env2 (add_evals con ids) `thenSmpl` \ (env3, ids') ->
let unf = mkUnfolding False con_app
- returnSmpl (Just tv_subst_env, (DataAlt con, vs', rhs')) }
+ returnSmpl (Just (tv_subst_env, (DataAlt con, vs', rhs'))) }
go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
-- If the case binder is alive, then we add the unfolding
go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs)
-- If the case binder is alive, then we add the unfolding
bind_args env bs (drop n_drop_tys args) $ \ env ->
let
con_app = mkConApp dc (take n_drop_tys args ++ con_args)
bind_args env bs (drop n_drop_tys args) $ \ env ->
let
con_app = mkConApp dc (take n_drop_tys args ++ con_args)
-- args are aready OutExprs, but bs are InIds
in
simplNonRecX env bndr con_app $ \ env ->
-- args are aready OutExprs, but bs are InIds
in
simplNonRecX env bndr con_app $ \ env ->
-- This has been this way for a long time, so I'll leave it,
-- but I can't convince myself that it's right.
-- This has been this way for a long time, so I'll leave it,
-- but I can't convince myself that it's right.
- = mkDupableAlt env case_bndr' dupable_cont alt `thenSmpl` \ (floats1, alt') ->
- addFloats env floats1 $ \ env ->
- go env alts `thenSmpl` \ (floats2, alts') ->
- returnSmpl (floats2, alt' : alts')
+ = do { (floats1, mb_alt') <- mkDupableAlt env case_bndr' dupable_cont alt
+ ; addFloats env floats1 $ \ env -> do
+ { (floats2, alts') <- go env alts
+ ; returnSmpl (floats2, case mb_alt' of
+ Just alt' -> alt' : alts'
+ Nothing -> alts'
+ )}}
- = simplAlt env [] case_bndr' alt cont `thenSmpl` \ (mb_reft, (con, bndrs', rhs')) ->
+ = simplAlt env [] case_bndr' alt cont `thenSmpl` \ mb_stuff ->
+ case mb_stuff of {
+ Nothing -> returnSmpl (emptyFloats env, Nothing) ;
+
+ Just (reft, (con, bndrs', rhs')) ->
- returnSmpl (emptyFloats env, (con, bndrs', rhs'))
+ returnSmpl (emptyFloats env, Just (con, bndrs', rhs'))
-- It is worth checking for a small RHS because otherwise we
-- get extra let bindings that may cause an extra iteration of the simplifier to
-- inline back in place. Quite often the rhs is just a variable or constructor.
-- It is worth checking for a small RHS because otherwise we
-- get extra let bindings that may cause an extra iteration of the simplifier to
-- inline back in place. Quite often the rhs is just a variable or constructor.
| otherwise = not (isDeadBinder bndr)
-- The deadness info on the new Ids is preserved by simplBinders
| otherwise = not (isDeadBinder bndr)
-- The deadness info on the new Ids is preserved by simplBinders
in
-- If we try to lift a primitive-typed something out
-- for let-binding-purposes, we will *caseify* it (!),
in
-- If we try to lift a primitive-typed something out
-- for let-binding-purposes, we will *caseify* it (!),
) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
-- Notice the funky mkPiTypes. If the contructor has existentials
-- it's possible that the join point will be abstracted over
-- type varaibles as well as term variables.
-- Notice the funky mkPiTypes. If the contructor has existentials
-- it's possible that the join point will be abstracted over
-- type varaibles as well as term variables.
- returnSmpl (unitFloat env join_bndr join_rhs, (con, bndrs', join_call))
+ returnSmpl (unitFloat env join_bndr join_rhs, Just (con, bndrs', join_call)) }