import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
import CoreSyn
import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- SimpleUnfolding(..),
- FormSummary, whnfOrBottom,
+ FormSummary, whnfOrBottom, okToInline,
smallEnoughToInline )
-import Specialise ( substSpecEnvRhs )
-import BinderInfo ( BinderInfo, noBinderInfo, okToInline )
+import CoreUtils ( coreExprCc )
+import BinderInfo ( BinderInfo, noBinderInfo )
-import CostCentre ( CostCentre, isCurrentCostCentre )
-import Id ( idType, getIdInfo, getIdUnfolding,
+import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
+import Id ( idType, getIdUnfolding,
getIdSpecialisation, setIdSpecialisation,
idMustBeINLINEd, idHasNoFreeTyVars,
mkIdWithNewUniq, mkIdWithNewType,
- elemIdEnv, isNullIdEnv, addOneToIdEnv
+ IdEnv, lookupIdEnv, delOneFromIdEnv, elemIdEnv, isNullIdEnv, addOneToIdEnv
)
import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
+import OccurAnal ( occurAnalyseGlobalExpr )
import Literal ( isNoRepLit )
import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
import SimplEnv
import Type ( instantiateTy, mkTyVarTy )
import TyCon ( tyConFamilySize )
import TyVar ( TyVar, cloneTyVar,
- isEmptyTyVarEnv, addToTyVarEnv,
+ isEmptyTyVarEnv, addToTyVarEnv, delFromTyVarEnv,
addOneToTyVarSet, elementOfTyVarSet
)
import Maybes ( maybeToBool )
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_`
| maybeToBool maybe_specialisation
= tick SpecialisationDone `thenSmpl_`
simplExpr (bindTyVars env spec_bindings)
- spec_template
+ (occurAnalyseGlobalExpr spec_template)
remaining_args
result_ty
- -- If there's an InUnfolding it means that there's no
- -- let-binding left for the thing, so we'd better inline it!
- | must_unfold
- = let
- Just (_, _, InUnfolding rhs_env rhs) = info_from_env
- in
- unfold var rhs_env rhs args result_ty
-
- -- Conditional unfolding. There's a binding for the
+ -- Look for an unfolding. There's a binding for the
-- thing, but perhaps we want to inline it anyway
- | ( maybeToBool maybe_unfolding_info
+ | 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) (getEnclosingCC unf_env)
+ && (inline_call || ok_to_inline)
+ && costCentreOk (getEnclosingCC env) (coreExprCc unf_template)
+ =
+{-
+ pprTrace "Unfolding" (ppr var) $
+ simplCount `thenSmpl` \ n ->
+ (if n > 1000 then
+ pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
+ else
+ id
)
- = pprTrace "Unfolding" (ppr var) $
- unfold var unf_env unf_template args result_ty
+ (if n>4000 then
+ returnSmpl (mkGenApp (Var var) args)
+ else
+-}
+ 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)
+ = returnSmpl (mkGenApp (Var var') args)
where
- info_from_env = lookupOutIdEnv env var
- unfolding_from_id = getIdUnfolding var
+ (var', occ_info, unfolding) = case lookupOutIdEnv env var of
+ Just stuff -> stuff
+ Nothing -> (var, noBinderInfo, getIdUnfolding var)
---------- Magic unfolding stuff
- maybe_magic_result = case unfolding_from_id of
+ maybe_magic_result = case unfolding of
MagicUnfolding _ magic_fn -> applyMagicUnfoldingFun magic_fn
env args
other -> Nothing
- (Just magic_result) = maybe_magic_result
+ Just magic_result = maybe_magic_result
---------- Unfolding stuff
- must_unfold = case info_from_env of
- Just (_, _, InUnfolding _ _) -> True
- other -> False
-
- maybe_unfolding_info
- = case (info_from_env, unfolding_from_id) of
-
- (Just (_, occ_info, OutUnfolding enc_cc unf), _)
- -> Just (occ_info, setEnclosingCC env enc_cc, unf)
-
- (_, CoreUnfolding unf)
- -> Just (noBinderInfo, env, unf)
-
- other -> Nothing
-
- Just (occ_info, unf_env, simple_unfolding) = maybe_unfolding_info
- SimpleUnfolding form guidance unf_template = simple_unfolding
+ has_unfolding = case unfolding of
+ CoreUnfolding _ _ _ -> True
+ other -> False
+
+ CoreUnfolding form guidance unf_template = unfolding
+ unf_env = zapSubstEnvs env
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
---------- Specialisation stuff
(ty_args, remaining_args) = initialTyArgs args
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
- small_enough = smallEnoughToInline arg_evals is_case_scrutinee guidance
+ 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]
- is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
+ is_evald (VarArg v) = isEvaluated (lookupUnfolding env v)
is_evald (LitArg l) = True
--- Perform the unfolding
-unfold var unf_env unf_template args result_ty
- =
-{-
- simplCount `thenSmpl` \ n ->
- (if n > 1000 then
- pprTrace "Ticks > 1000 and unfolding" (sep [space, int n, ppr var])
- else
- id
- )
- (if n>4000 then
- returnSmpl (mkGenApp (Var var) args)
- else
--}
- tickUnfold var `thenSmpl_`
- simplExpr unf_env unf_template args result_ty
-- costCentreOk checks that it's ok to inline this thing
-- regardless of whether E is a WHNF or not.
costCentreOk cc_encl cc_rhs
- = isCurrentCostCentre cc_encl || not (isCurrentCostCentre cc_rhs)
+ = isCurrentCostCentre cc_encl || not (noCostCentreAttached cc_rhs)
\end{code}
\begin{code}
simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId)
-simplBinder env (id, _)
+simplBinder env (id, occ_info)
| not_in_scope -- Not in scope, 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
- env' = setIdEnv env (addOneToIdEnv in_scope_ids id id, id_subst)
+ env' = setIdEnv env (new_in_scope_ids id, id_subst)
in
returnSmpl (env', id)
#if DEBUG
-- I reckon the empty-env thing should catch
-- most no-free-tyvars things, so this test should be redundant
- (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
+-- (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x))
#endif
(let
-- id1 has its type zapped
-- id2 has its SpecEnv zapped
id2 | isEmptySpecEnv spec_env = id1
- | otherwise = setIdSpecialisation id spec_env'
+ | otherwise = setIdSpecialisation id1 spec_env'
in
if not_in_scope then
- -- No need to clone
+ -- 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 (addOneToIdEnv in_scope_ids id id2, id_subst)
+ env' = setIdEnv env (new_in_scope_ids id2,
+ delOneFromIdEnv id_subst id)
in
returnSmpl (env', id2)
else
getUniqueSmpl `thenSmpl` \ uniq ->
let
id3 = mkIdWithNewUniq id2 uniq
- env' = setIdEnv env (addOneToIdEnv in_scope_ids id3 id3,
- addOneToIdEnv id_subst id (VarArg id3))
+ env' = setIdEnv env (new_in_scope_ids id3,
+ addOneToIdEnv id_subst id (SubstVar id3))
in
returnSmpl (env', id3)
)
where
- ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getSubstEnvs env
- empty_ty_subst = isEmptyTyVarEnv ty_subst
- not_in_scope = not (id `elemIdEnv` in_scope_ids)
+ ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getEnvs env
- ty = idType id
- ty' = instantiateTy ty_subst ty
+ empty_ty_subst = isEmptyTyVarEnv ty_subst
+ not_in_scope = not (id `elemIdEnv` in_scope_ids)
- spec_env = getIdSpecialisation id
- spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env
+ 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
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)
+ | not (tyvar `elementOfTyVarSet` tyvars)
+ = -- 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)
in
returnSmpl (env', tyvar')
where
- ((tyvars, ty_subst), (ids, id_subst)) = getSubstEnvs env
+ ((tyvars, ty_subst), (ids, id_subst)) = getEnvs env
simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar])
simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders
\end{code}
+
+
+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
+\end{code}
projects / ghc-hetmet.git / blobdiff