-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,
)
import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
-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 CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline )
+import CoreUnfold ( mkOtherCon, mkUnfolding, evaldUnfolding, callSiteInline )
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsValue,
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsValue,
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, eqType, substTy,
- mkTyVarTys, mkTyConApp
+ splitFunTy_maybe, splitFunTy, coreEqType
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
import TysPrim ( realWorldStatePrimTy )
import PrelInfo ( realWorldPrimId )
import BasicTypes ( TopLevelFlag(..), isTopLevel,
-- 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)
simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally env NotTopLevel bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside
| preInlineUnconditionally env NotTopLevel bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
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)
env2 = modifyInScope env1 bndr2 bndr2
in
completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
env2 = modifyInScope env1 bndr2 bndr2
in
completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 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')])
-- 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.
simplRecOrTopPair env top_lvl bndr bndr' rhs
| preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
simplRecOrTopPair env top_lvl bndr bndr' rhs
| preInlineUnconditionally env top_lvl bndr -- Check for unconditional inline
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
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
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
| otherwise = CoerceIt t1 cont -- They don't cancel, but
-- the inner one is redundant
| otherwise = CoerceIt t1 cont -- They don't cancel, but
-- the inner one is redundant
-- 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
(tvs,ids) = span isTyVar vs
in
simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
(tvs,ids) = span isTyVar vs
in
simplBinders env tvs `thenSmpl` \ (env1, tvs') ->
- let
- pat_res_ty = dataConResTy con (mkTyVarTys tvs')
- tv_subst = getTvSubst env
- in
- case coreRefineTys tvs' tv_subst pat_res_ty (idType case_bndr') of {
+ case coreRefineTys (getInScope env1) con tvs' (idType case_bndr') of {
Nothing -- Dead code; for now, I'm just going to put in an
-- error case so I can see them
-> let rhs' = mkApps (Var eRROR_ID)
Nothing -- Dead code; for now, I'm just going to put in an
-- error case so I can see them
-> let rhs' = mkApps (Var eRROR_ID)
Lit (mkStringLit "Impossible alternative (GADT)")]
in
simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
returnSmpl (Nothing, (DataAlt con, tvs' ++ ids', rhs')) ;
Lit (mkStringLit "Impossible alternative (GADT)")]
in
simplBinders env1 ids `thenSmpl` \ (env2, ids') ->
returnSmpl (Nothing, (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
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 ->