import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
-import CoreUnfold ( Unfolding, SimpleUnfolding, mkFormSummary,
+import CoreUnfold ( Unfolding, mkFormSummary, noUnfolding,
exprIsTrivial, whnfOrBottom, inlineUnconditionally,
FormSummary(..)
)
unTagBinders, squashableDictishCcExpr
)
import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd,
- addIdArity, getIdArity,
- getIdDemandInfo, addIdDemandInfo
+ addIdArity, getIdArity, getIdSpecialisation, setIdSpecialisation,
+ getIdDemandInfo, addIdDemandInfo, isSpecPragmaId
)
import Name ( isExported, isLocallyDefined )
import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
import SimplMonad
import SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders )
import SimplUtils
+import SpecEnv ( isEmptySpecEnv, substSpecEnv )
import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
mkFunTys, splitAlgTyConApp_maybe,
splitFunTys, splitFunTy_maybe, isUnpointedType
isSingleton, zipEqual, zipWithEqual, mapAndUnzip
)
import Outputable
+
\end{code}
The controlling flags, and what they do
simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds)
= --- No cloning necessary at top level
- simplBinder env binder `thenSmpl` \ (env1, out_id) ->
- simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) ->
- completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
- simpl_top_binds new_env binds `thenSmpl` \ binds2' ->
- returnSmpl (binds1' ++ binds2')
+ simplBinder env binder `thenSmpl` \ (env1, out_id) ->
+ simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) ->
+ completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1) ->
+ simpl_top_binds new_env binds `thenSmpl` \ binds2 ->
+ returnSmpl (binds1 ++ binds2)
simpl_top_binds env (Rec pairs : binds)
= -- No cloning necessary at top level, but we nevertheless
Variables
~~~~~~~~~
-Check if there's a macro-expansion, and if so rattle on. Otherwise do
-the more sophisticated stuff.
\begin{code}
-simplExpr env (Var v) args result_ty
- = case (runEager $ lookupId env v) of
- LitArg lit -- A boring old literal
- -> ASSERT( null args )
- returnSmpl (Lit lit)
-
- VarArg var -- More interesting! An id!
- -> completeVar env var args result_ty
- -- Either Id is in the local envt, or it's a global.
- -- In either case we don't need to apply the type
- -- environment to it.
+simplExpr env (Var var) args result_ty
+ = simplVar env False {- No InlineCall -} var args result_ty
\end{code}
Literals
where
-- PrimOps just need any types in them renamed.
- simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)
+ simpl_op (CCallOp label is_asm may_gc cconv arg_tys result_ty)
= mapEager (simplTy env) arg_tys `appEager` \ arg_tys' ->
simplTy env result_ty `appEager` \ result_ty' ->
- returnEager (CCallOp label is_asm may_gc arg_tys' result_ty')
+ returnEager (CCallOp label is_asm may_gc cconv arg_tys' result_ty')
simpl_op other_op = returnEager other_op
\end{code}
returnSmpl (Lam (TyBinder tyvar') body')
#ifdef DEBUG
-simplExpr env (Lam (TyBinder _) _) (_ : _) result_ty
- = panic "simplExpr:TyLam with non-TyArg"
+simplExpr env e@(Lam (TyBinder _) _) args@(_ : _) result_ty
+ = pprPanic "simplExpr:TyLam with non-TyArg" (ppr e $$ ppr args)
#endif
\end{code}
-- on the arguments we've already beta-reduced into the body of the lambda
= ASSERT( null args ) -- Value lambda must match value argument!
let
- new_env = markDangerousOccs env (take n orig_args)
+ new_env = markDangerousOccs env orig_args
in
simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -} result_ty
`thenSmpl` \ (expr', arity) ->
\begin{code}
simplExpr env expr@(Case scrut alts) args result_ty
- = simplCase env scrut alts (\env rhs -> simplExpr env rhs args result_ty) result_ty
+ = simplCase env scrut
+ (getSubstEnvs env, alts)
+ (\env rhs -> simplExpr env rhs args result_ty)
+ result_ty
\end{code}
Coercions
~~~~~~~~~
\begin{code}
-simplExpr env (Coerce coercion ty body) args result_ty
- = simplCoerce env coercion ty body args result_ty
-\end{code}
+simplExpr env (Note (Coerce to_ty from_ty) body) args result_ty
+ = simplCoerce env to_ty from_ty body args result_ty
+simplExpr env (Note (SCC cc) body) args result_ty
+ = simplSCC env cc body args result_ty
-Set-cost-centre
-~~~~~~~~~~~~~~~
-
-1) Eliminating nested sccs ...
-We must be careful to maintain the scc counts ...
-
-\begin{code}
-simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
- | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
- -- eliminate inner scc if no call counts and same cc as outer
- = simplExpr env (SCC cc1 expr) args result_ty
-
- | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
- -- eliminate outer scc if no call counts associated with either ccs
- = simplExpr env (SCC cc2 expr) args result_ty
-\end{code}
-
-2) Moving sccs inside lambdas ...
-
-\begin{code}
-simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
- | not (isSccCountCostCentre cc)
- -- move scc inside lambda only if no call counts
- = simplExpr env (Lam binder (SCC cc body)) args result_ty
-
-simplExpr env (SCC cc (Lam binder body)) args result_ty
- -- always ok to move scc inside type/usage lambda
- = simplExpr env (Lam binder (SCC cc body)) args result_ty
-\end{code}
+-- InlineCall is simple enough to deal with on the spot
+-- The only complication is that we slide the InlineCall
+-- inwards past any function arguments
+simplExpr env (Note InlineCall expr) args result_ty
+ = go expr args
+ where
+ go (Var v) args = simplVar env True {- InlineCall -} v args result_ty
-3) Eliminating dict sccs ...
+ go (App fun arg) args = simplArg env arg `appEager` \ arg' ->
+ go fun (arg' : args)
-\begin{code}
-simplExpr env (SCC cc expr) args result_ty
- | squashableDictishCcExpr cc expr
- -- eliminate dict cc if trivial dict expression
- = simplExpr env expr args result_ty
+ go other args = -- Unexpected discard; report it
+ pprTrace "simplExpr: discarding InlineCall" (ppr expr) $
+ simplExpr env other args result_ty
\end{code}
-4) Moving arguments inside the body of an scc ...
-This moves the cost of doing the application inside the scc
-(which may include the cost of extracting methods etc)
-\begin{code}
-simplExpr env (SCC cost_centre body) args result_ty
- = let
- new_env = setEnclosingCC env cost_centre
- in
- simplExpr new_env body args result_ty `thenSmpl` \ body' ->
- returnSmpl (SCC cost_centre body')
-\end{code}
%************************************************************************
%* *
| otherwise -- OK, use the big hammer
= -- Deal with the big lambda part
- simplTyBinders env tyvars `thenSmpl` \ (lam_env, tyvars') ->
+ simplTyBinders rhs_env tyvars `thenSmpl` \ (lam_env, tyvars') ->
let
body_ty = applyTys rhs_ty (mkTyVarTys tyvars')
in
\end{code}
+%************************************************************************
+%* *
+\subsection[Simplify-var]{Variables}
+%* *
+%************************************************************************
+
+Check if there's a macro-expansion, and if so rattle on. Otherwise do
+the more sophisticated stuff.
+
+\begin{code}
+simplVar env inline_call var args result_ty
+ = case lookupIdSubst env var of
+
+ Just (SubstExpr ty_subst id_subst expr)
+ -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty
+
+ Just (SubstLit lit) -- A boring old literal
+ -> ASSERT( null args )
+ returnSmpl (Lit lit)
+
+ Just (SubstVar var') -- More interesting! An id!
+ -> completeVar env inline_call var' args result_ty
+
+ Nothing -- Not in the substitution; hand off to completeVar
+ -> completeVar env inline_call var args result_ty
+\end{code}
+
%************************************************************************
%* *
\begin{code}
-- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
-simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
- = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args result_ty) result_ty
+simplCoerce env to_ty from_ty expr@(Case scrut alts) args result_ty
+ = simplCase env scrut (getSubstEnvs env, alts)
+ (\env rhs -> simplCoerce env to_ty from_ty rhs args result_ty)
+ result_ty
-- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
-simplCoerce env coercion ty (Let bind body) args result_ty
- = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
+simplCoerce env to_ty from_ty (Let bind body) args result_ty
+ = simplBind env bind (\env -> simplCoerce env to_ty from_ty body args result_ty) result_ty
-- Default case
-simplCoerce env coercion ty expr args result_ty
- = simplTy env ty `appEager` \ ty' ->
- simplTy env expr_ty `appEager` \ expr_ty' ->
- simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
- returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
- where
- expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
+-- NB: we do *not* push the argments inside the coercion
+simplCoerce env to_ty from_ty expr args result_ty
+ = simplTy env to_ty `appEager` \ to_ty' ->
+ simplTy env from_ty `appEager` \ from_ty' ->
+ simplExpr env expr [] from_ty' `thenSmpl` \ expr' ->
+ returnSmpl (mkGenApp (mkCoerce to_ty' from_ty' expr') args)
+ where
-- Try cancellation; we do this "on the way up" because
-- I think that's where it'll bite best
- mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
- mkCoerce coercion ty body = Coerce coercion ty body
+ mkCoerce to_ty1 from_ty1 (Note (Coerce to_ty2 from_ty2) body)
+ = ASSERT( from_ty1 == to_ty2 )
+ mkCoerce to_ty1 from_ty2 body
+ mkCoerce to_ty from_ty body
+ | to_ty == from_ty = body
+ | otherwise = Note (Coerce to_ty from_ty) body
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Simplify-scc]{SCC expressions
+%* *
+%************************************************************************
+
+1) Eliminating nested sccs ...
+We must be careful to maintain the scc counts ...
+
+\begin{code}
+simplSCC env cc1 (Note (SCC cc2) expr) args result_ty
+ | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
+ -- eliminate inner scc if no call counts and same cc as outer
+ = simplSCC env cc1 expr args result_ty
+
+ | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
+ -- eliminate outer scc if no call counts associated with either ccs
+ = simplSCC env cc2 expr args result_ty
+\end{code}
+
+2) Moving sccs inside lambdas ...
+
+\begin{code}
+simplSCC env cc (Lam binder@(ValBinder _) body) args result_ty
+ | not (isSccCountCostCentre cc)
+ -- move scc inside lambda only if no call counts
+ = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
+
+simplSCC env cc (Lam binder body) args result_ty
+ -- always ok to move scc inside type/usage lambda
+ = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
+\end{code}
+
+3) Eliminating dict sccs ...
+
+\begin{code}
+simplSCC env cc expr args result_ty
+ | squashableDictishCcExpr cc expr
+ -- eliminate dict cc if trivial dict expression
+ = simplExpr env expr args result_ty
+\end{code}
+
+4) Moving arguments inside the body of an scc ...
+This moves the cost of doing the application inside the scc
+(which may include the cost of extracting methods etc)
+
+\begin{code}
+simplSCC env cc body args result_ty
+ = let
+ new_env = setEnclosingCC env cc
+ in
+ simplExpr new_env body args result_ty `thenSmpl` \ body' ->
+ returnSmpl (Note (SCC cc) body')
\end{code}
\begin{code}
-- Dead code is now discarded by the occurrence analyser,
-simplNonRec env binder@(id,occ_info) rhs body_c body_ty
- | inlineUnconditionally ok_to_dup id occ_info
+simplNonRec env binder@(id,_) rhs body_c body_ty
+ | inlineUnconditionally binder
= -- The binder is used in definitely-inline way in the body
-- So add it to the environment, drop the binding, and continue
- body_c (extendEnvGivenInlining env id occ_info rhs)
+ body_c (bindIdToExpr env binder rhs)
| idWantsToBeINLINEd id
= complete_bind env rhs -- Don't mess about with floating or let-to-case on
-- we can't trivially do let-to-case (because there may be some unboxed
-- things bound in letrecs that aren't really recursive).
| isUnpointedType rhs_ty && not rhs_is_whnf
- = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id)))
+ = simplCase env rhs (getSubstEnvs env, PrimAlts [] (BindDefault binder (Var id)))
(\env rhs -> complete_bind env rhs) body_ty
-- Try let-to-case; see notes below about let-to-case
-- the end of simplification.
)
= tick Let2Case `thenSmpl_`
- simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
+ simplCase env rhs (getSubstEnvs env, AlgAlts [] (BindDefault binder (Var id)))
(\env rhs -> complete_bind env rhs) body_ty
-- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
-- NB: it's tidier to call complete_bind not simpl_bind, else
= tick CaseFloatFromLet `thenSmpl_`
-- First, bind large let-body if necessary
- if ok_to_dup || isSingleton (nonErrorRHSs alts)
+ if isSingleton (nonErrorRHSs alts)
then
- simplCase env scrut alts (\env rhs -> simpl_bind env rhs) body_ty
+ simplCase env scrut (getSubstEnvs env, alts)
+ (\env rhs -> simpl_bind env rhs) body_ty
else
bindLargeRhs env [binder] body_ty body_c `thenSmpl` \ (extra_binding, new_body) ->
let
body_c' = \env -> simplExpr env new_body [] body_ty
case_c = \env rhs -> simplNonRec env binder rhs body_c' body_ty
in
- simplCase env scrut alts case_c body_ty `thenSmpl` \ case_expr ->
+ simplCase env scrut (getSubstEnvs env, alts) case_c body_ty `thenSmpl` \ case_expr ->
returnSmpl (Let extra_binding case_expr)
-- None of the above; simplify rhs and tidy up
simpl_bind env rhs = complete_bind env rhs
complete_bind env rhs
- = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) ->
- simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
+ = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) ->
+ simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) ->
completeNonRec env_w_clone binder
- (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
- body_c new_env `thenSmpl` \ body' ->
+ (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
+ body_c new_env `thenSmpl` \ body' ->
returnSmpl (mkCoLetsAny binds body')
-- All this stuff is computed at the start of the simpl_bind loop
float_lets = switchIsSet env SimplFloatLetsExposingWHNF
float_primops = switchIsSet env SimplOkToFloatPrimOps
- ok_to_dup = switchIsSet env SimplOkToDupCode
always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
try_let_to_case = switchIsSet env SimplLetToCase
no_float = switchIsSet env SimplNoLetFromStrictLet
ValueForm -> True
other -> False
- float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
+ float_exposes_hnf = floatExposesHNF float_lets float_primops rhs
let_floating_ok = (will_be_demanded && not no_float) ||
always_float_let_from_let ||
-> InBinder -> OutId -> OutExpr -- Id and RHS
-> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
-completeBind env binder@(_,occ_info) new_id new_rhs
- | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
- = (env, new_binds)
-
- | atomic_rhs -- If rhs (after eta reduction) is atomic
+completeBind env binder@(old_id,occ_info) new_id new_rhs
+ | not (idMustNotBeINLINEd new_id)
+ && atomic_rhs -- If rhs (after eta reduction) is atomic
&& not (isExported new_id) -- and binder isn't exported
+ && not (isSpecPragmaId new_id) -- Don't discard spec prag Ids
+
= -- Drop the binding completely
let
env1 = notInScope env new_id
in
(env2, [])
- | atomic_rhs -- Rhs is atomic, and new_id is exported
- && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False }
- = -- The local variable v will be eliminated next time round
- -- in favour of new_id, so it's a waste to replace all new_id's with v's
- -- this time round.
- -- This case is an optional improvement; saves a simplifier iteration
- (env, [(new_id, eta'd_rhs)])
-
| otherwise -- Non-atomic
+ -- The big deal here is that we simplify the
+ -- SpecEnv of the Id, if any. We used to do that in simplBinders, but
+ -- that didn't work because it didn't take account of the fact that
+ -- one of the mutually recursive group might mention one of the others
+ -- in its SpecEnv
= let
- env1 = extendEnvGivenBinding env occ_info new_id new_rhs
- in
+ id_w_specenv | isEmptySpecEnv spec_env = new_id
+ | otherwise = setIdSpecialisation new_id spec_env'
+
+ env1 | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
+ = extendEnvGivenUnfolding env id_w_specenv occ_info noUnfolding
+ -- Still need to record the new_id with its SpecEnv
+
+ | otherwise -- Can inline it
+ = extendEnvGivenBinding env occ_info id_w_specenv new_rhs
+
+ new_binds = [(id_w_specenv, new_rhs)]
+ in
(env1, new_binds)
where
- new_binds = [(new_id, new_rhs)]
+ spec_env = getIdSpecialisation old_id
+ spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
+ (ty_subst,id_subst) = getSubstEnvs env
+
atomic_rhs = is_atomic eta'd_rhs
eta'd_rhs = case lookForConstructor env new_rhs of
Just v -> Var v
simplRecursiveGroup env new_ids []
= returnSmpl ([], env)
-simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs)
- | inlineUnconditionally ok_to_dup id occ_info
+simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs)
+ | inlineUnconditionally binder
= -- Single occurrence, so drop binding and extend env with the inlining
-- This is a little delicate, because what if the unique occurrence
-- is *before* this binding? This'll never happen, because
-- If these claims aren't right Core Lint will spot an unbound
-- variable. A quick fix is to delete this clause for simplRecursiveGroup
let
- new_env = extendEnvGivenInlining env new_id occ_info rhs
+ new_env = bindIdToExpr env binder rhs
in
simplRecursiveGroup new_env new_ids pairs
-
| otherwise
= simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
let
- new_id' = new_id `withArity` arity
+ new_id' = new_id `withArity` arity
(new_env, new_binds') = completeBind env binder new_id' new_rhs
in
simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
returnSmpl (new_binds' ++ new_pairs, final_env)
- where
- ok_to_dup = switchIsSet env SimplOkToDupCode
\end{code}
-- fltRhs has same invariant as fltBind
fltRhs rhs
| (always_float_let_from_let ||
- floatExposesHNF True False False rhs)
+ floatExposesHNF True False rhs)
= fltExpr rhs
| otherwise
simplArg env (LitArg lit) = returnEager (LitArg lit)
simplArg env (TyArg ty) = simplTy env ty `appEager` \ ty' ->
returnEager (TyArg ty')
-simplArg env (VarArg id) = lookupId env id
+simplArg env arg@(VarArg id)
+ = case lookupIdSubst env id of
+ Just (SubstVar id') -> returnEager (VarArg id')
+ Just (SubstLit lit) -> returnEager (LitArg lit)
+ Just (SubstExpr _ __) -> panic "simplArg"
+ Nothing -> case lookupOutIdEnv env id of
+ Just (id', _, _) -> returnEager (VarArg id')
+ Nothing -> returnEager arg
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff