import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
import CoreSyn
import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- FormSummary, whnfOrBottom,
+ FormSummary, whnfOrBottom, okToInline,
smallEnoughToInline )
import CoreUtils ( coreExprCc )
-import BinderInfo ( BinderInfo, noBinderInfo, okToInline )
+import BinderInfo ( BinderInfo, noBinderInfo )
import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
-import Id ( idType, getIdInfo, getIdUnfolding,
+import Id ( idType, getIdUnfolding, externallyVisibleId,
getIdSpecialisation, setIdSpecialisation,
idMustBeINLINEd, idHasNoFreeTyVars,
mkIdWithNewUniq, mkIdWithNewType,
IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
)
-import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
+import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, emptySpecEnv )
import OccurAnal ( occurAnalyseGlobalExpr )
import Literal ( isNoRepLit )
import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
This where all the heavy-duty unfolding stuff comes into its own.
\begin{code}
-completeVar env var args result_ty
+completeVar env inline_call var args result_ty
| maybeToBool maybe_magic_result
= tick MagicUnfold `thenSmpl_`
-- Look for an unfolding. There's a binding for the
-- thing, but perhaps we want to inline it anyway
| has_unfolding
- && (not essential_unfoldings_only || idMustBeINLINEd var)
- -- If "essential_unfoldings_only" is true we do no inlinings at all,
- -- EXCEPT for things that absolutely have to be done
- -- (see comments with idMustBeINLINEd)
- && ok_to_inline
- && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)
+ && (idMustBeINLINEd var ||
+ (not essential_unfoldings_only
+ -- If "essential_unfoldings_only" is true we do no inlinings at all,
+ -- EXCEPT for things that absolutely have to be done
+ -- (see comments with idMustBeINLINEd)
+ && (inline_call || ok_to_inline)
+ && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)))
=
{-
pprTrace "Unfolding" (ppr var) $
tickUnfold var `thenSmpl_`
simplExpr unf_env unf_template args result_ty
+ | inline_call -- There was an InlineCall note, but we didn't inline!
+ = returnSmpl (mkGenApp (Note InlineCall (Var var')) args)
+
| otherwise
= returnSmpl (mkGenApp (Var var') args)
---------- Specialisation stuff
(ty_args, remaining_args) = initialTyArgs args
- maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args
+ maybe_specialisation = lookupSpecEnv (ppr var) (getIdSpecialisation var) ty_args
Just (spec_bindings, spec_template) = maybe_specialisation
sw_chkr = getSwitchChecker env
essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee
- ok_to_inline = okToInline (whnfOrBottom form) small_enough occ_info
+ ok_to_inline = okToInline var (whnfOrBottom form) small_enough occ_info
small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance
arg_evals = [is_evald arg | arg <- args, isValArg arg]
\begin{code}
simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
simplBinder env (id, occ_info)
- | not_in_scope -- Not in scope, so no need to clone
+ | no_need_to_clone -- Not in scope (or cloning disabled), so no need to clone
&& empty_ty_subst -- No type substitution to do inside the Id
&& isNullIdEnv id_subst -- No id substitution to do inside the Id
= let
-- id1 has its type zapped
id1 | empty_ty_subst = id
| otherwise = mkIdWithNewType id ty'
-
- -- id2 has its SpecEnv zapped
- id2 | isEmptySpecEnv spec_env = id1
- | otherwise = setIdSpecialisation id spec_env'
+ -- id2 has its SpecEnv zapped (see comment inside Simplify.completeBind)
+ id2 | empty_spec_env = id1
+ | otherwise = setIdSpecialisation id1 emptySpecEnv
in
- if not_in_scope then
- -- No need to clone
+ if no_need_to_clone then
+ -- No need to clone, but we *must* zap any current substitution
+ -- for the variable. For example:
+ -- (\x.e) with id_subst = [x |-> e']
+ -- Here we must simply zap the substitution for x
let
- env' = setIdEnv env (new_in_scope_ids id2, id_subst)
+ new_id_subst = delOneFromIdEnv id_subst id
+ new_env = setIdEnv env (new_in_scope_ids id2, new_id_subst)
in
- returnSmpl (env', id2)
+ returnSmpl (new_env, id2)
else
-- Must clone
getUniqueSmpl `thenSmpl` \ uniq ->
let
- id3 = mkIdWithNewUniq id2 uniq
- env' = setIdEnv env (new_in_scope_ids id3,
- addOneToIdEnv id_subst id (SubstVar id3))
+ id3 = mkIdWithNewUniq id2 uniq
+ new_env = setIdEnv env (new_in_scope_ids id3,
+ addOneToIdEnv id_subst id (SubstVar id3))
in
- returnSmpl (env', id3)
+ returnSmpl (new_env, id3)
)
where
((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
- empty_ty_subst = isEmptyTyVarEnv ty_subst
- not_in_scope = not (id `elemIdEnv` in_scope_ids)
+ empty_ty_subst = isEmptyTyVarEnv ty_subst
+ empty_spec_env = isEmptySpecEnv (getIdSpecialisation id)
+
+ no_need_to_clone = not need_to_clone
+ need_to_clone = not (externallyVisibleId id) &&
+ ( elemIdEnv id in_scope_ids || clone_binds_please)
+ {-
+ The SimplCloneBinds option isn't just here as another simplifier knob we can
+ twiddle. Prior to floating bindings outwards, we have to make sure that no
+ duplicate bindings exist as floating may cause bindings with identical
+ uniques to come into scope, with disastrous consequences.
+
+ To avoid this situation, we make sure that cloning is turned *on* in the
+ simplifier pass prior to running an outward floating pass.
+ -}
+ clone_binds_please = switchIsOn sw_chkr SimplCloneBinds
new_in_scope_ids id' = addOneToIdEnv in_scope_ids id' (id', occ_info, NoUnfolding)
ty = idType id
ty' = instantiateTy ty_subst ty
-
- spec_env = getIdSpecialisation id
- spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
+
+ sw_chkr = getSwitchChecker env
+
simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId])
simplBinders env binders = mapAccumLSmpl simplBinder env binders
\begin{code}
simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar)
simplTyBinder env tyvar
- | not (tyvar `elementOfTyVarSet` tyvars) -- No need to clone
- = let
- env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, ty_subst)
+ | no_need_to_clone
+ = -- No need to clone; but must zap any binding for tyvar
+ -- see comments with simplBinder above
+ let
+ env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar,
+ delFromTyVarEnv ty_subst tyvar)
in
returnSmpl (env', tyvar)
returnSmpl (env', tyvar')
where
((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
+ no_need_to_clone = not (tyvar `elementOfTyVarSet` tyvars) &&
+ not clone_binds_please
-simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
-simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
-\end{code}
-
+ clone_binds_please = switchIsOn sw_chkr SimplCloneBinds
+ sw_chkr = getSwitchChecker env
-substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
-It exploits the known structure of a SpecEnv's RHS to have fewer
-equations.
-\begin{code}
-substSpecEnvRhs te ve rhs
- = go te ve rhs
- where
- go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
- go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
- Just (SubstVar v') -> VarArg v'
- Just (SubstLit l) -> LitArg l
- Nothing -> VarArg v)
- go te ve (Var v) = case lookupIdEnv ve v of
- Just (SubstVar v') -> Var v'
- Just (SubstLit l) -> Lit l
- Nothing -> Var v
-
- -- These equations are a bit half baked, because
- -- they don't deal properly wih capture.
- -- But I'm sure it'll never matter... sigh.
- go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
- where
- te' = delFromTyVarEnv te tyvar
-
- go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
- where
- ve' = delOneFromIdEnv ve v
+simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
+simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
\end{code}
projects / ghc-hetmet.git / blobdiff