X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplVar.lhs;h=2cfaf9144f07c0c6a17b11a1d36b1e6fecc1a474;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=7ed82def06ec3bb833faa67e4179d71cab671c03;hpb=350263b7fc9352f7eecb1769fe1840b0e20c7e04;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 7ed82de..2cfaf91 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -16,19 +16,19 @@ import {-# SOURCE #-} Simplify ( simplExpr ) 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 ) @@ -53,7 +53,7 @@ import Outputable 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_` @@ -72,12 +72,13 @@ completeVar env var args result_ty -- 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) $ @@ -94,6 +95,9 @@ completeVar env var args result_ty 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) @@ -127,7 +131,7 @@ completeVar env var args result_ty ---------- 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 @@ -135,7 +139,7 @@ completeVar env var args result_ty 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] @@ -173,7 +177,7 @@ When we hit a binder we may need to \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 @@ -192,40 +196,57 @@ simplBinder env (id, occ_info) -- 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 @@ -234,9 +255,12 @@ 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) @@ -250,38 +274,13 @@ simplTyBinder 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}