X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=c15a7b3f0a2015aa58484b8c0b89f978bb04f2e9;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=587406afad7aa46676a131075a5237b564508aec;hpb=605ed32b4cd3972520f156d3f2924ba3c2af4505;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 587406a..c15a7b3 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -7,6 +7,7 @@ module SimplEnv ( nullSimplEnv, getEnvs, setTyEnv, setIdEnv, notInScope, setSubstEnvs, zapSubstEnvs, + emptySubstEnvs, getSubstEnvs, bindTyVar, bindTyVars, simplTy, @@ -28,7 +29,7 @@ module SimplEnv ( -- Types SwitchChecker, - SimplEnv, + SimplEnv, SubstEnvs, UnfoldConApp, SubstInfo(..), @@ -42,7 +43,7 @@ module SimplEnv ( #include "HsVersions.h" import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc, - okToInline, isOneFunOcc, + isOneFunOcc, BinderInfo ) import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, @@ -50,6 +51,7 @@ import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, ) import CoreSyn import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom, + okToInline, Unfolding(..), FormSummary(..), calcUnfoldingGuidance ) import CoreUtils ( coreExprCc ) @@ -58,10 +60,12 @@ import CostCentre ( CostCentre, isCurrentCostCentre, useCurrentCostCentre, currentOrSubsumedCosts ) import FiniteMap -- lots of things -import Id ( getInlinePragma, +import Id ( IdEnv, IdSet, Id, + getInlinePragma, nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv, addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly, - IdEnv, IdSet, Id ) + idMustBeINLINEd + ) import Literal ( Literal ) import Maybes ( expectJust ) import OccurAnal ( occurAnalyseExpr ) @@ -154,6 +158,8 @@ type SimplValEnv = (IdEnv StuffAboutId, -- Domain includes *all* in-scope -- Ids in the domain of the substitution are *not* in scope; -- they *must* be substituted for the given OutArg +type SubstEnvs = (TyVarEnv Type, IdEnv SubstInfo) + data SubstInfo = SubstVar OutId -- The Id maps to an already-substituted atom | SubstLit Literal -- ...ditto literal @@ -204,9 +210,22 @@ setIdEnv :: SimplEnv -> SimplValEnv -> SimplEnv setIdEnv (SimplEnv chkr encl_cc ty_env _ con_apps) id_env = SimplEnv chkr encl_cc ty_env id_env con_apps -setSubstEnvs :: SimplEnv -> TyVarEnv Type -> IdEnv SubstInfo -> SimplEnv +getSubstEnvs :: SimplEnv -> SubstEnvs +getSubstEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _) = (ty_subst, id_subst) + +emptySubstEnvs :: SubstEnvs +emptySubstEnvs = (emptyTyVarEnv, nullIdEnv) + +setSubstEnvs :: SimplEnv -> SubstEnvs -> SimplEnv setSubstEnvs (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps) - ty_subst id_subst + (ty_subst, id_subst) + = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps + +combineEnvs :: SimplEnv -- Get substitution from here + -> SimplEnv -- Get in-scope info from here + -> SimplEnv +combineEnvs (SimplEnv _ _ (_, ty_subst) (_, id_subst) _) + (SimplEnv chkr encl_cc (in_scope_tyvars, _) (in_scope_ids, _) con_apps) = SimplEnv chkr encl_cc (in_scope_tyvars, ty_subst) (in_scope_ids, id_subst) con_apps zapSubstEnvs :: SimplEnv -> SimplEnv @@ -246,7 +265,7 @@ setCaseScrutinee (SimplEnv chkr encl_cc ty_env id_env con_apps) the RHS of an Id that's marked with an INLINE pragma. It is going to be inlined wherever they are used, and then all the inlining will take effect. Meanwhile, there isn't much point in doing anything to the -as-yet-un-INLINEd rhs. Furthremore, it's very important to switch off +as-yet-un-INLINEd rhs. Furthermore, it's very important to switch off inlining! because (a) not doing so will inline a worker straight back into its wrapper! @@ -274,12 +293,32 @@ all the unfolding info. At one point we did it by modifying the chkr so that it said "EssentialUnfoldingsOnly", but that prevented legitmate, and important, simplifications happening in the body of the RHS. +6/98 update: + +We don't prevent inlining from happening for identifiers +that are marked as must-be-inlined. An example of where +doing this is crucial is: + + class Bar a => Foo a where + ...g.... + {-# INLINE f #-} + f :: Foo a => a -> b + f x = ....Foo_sc1... + +If `f' needs to peer inside Foo's superclass, Bar, it refers +to the appropriate super class selector, which is marked as +must-inlineable. We don't generate any code for a superclass +selector, so failing to inline it in the RHS of `f' will +leave a reference to a non-existent id, with bad consequences. + \begin{code} switchOffInlining :: SimplEnv -> SimplEnv switchOffInlining (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) = SimplEnv chkr encl_cc ty_env (mapUFM forget in_scope_ids, id_subst) nullConApps where - forget (id, binder_info, rhs_info) = (id, noBinderInfo, NoUnfolding) + forget (id, binder_info, rhs_info) + | idMustBeINLINEd id = (id, binder_info, rhs_info) + | otherwise = (id, noBinderInfo, NoUnfolding) \end{code} @@ -396,15 +435,15 @@ lookupUnfolding env id Just (_,_,info) -> info Nothing -> NoUnfolding -modifyOutEnvItem :: (OutId, BinderInfo, Unfolding) - -> (OutId, BinderInfo, Unfolding) - -> (OutId, BinderInfo, Unfolding) -modifyOutEnvItem (id, occ, info1) (_, _, info2) - = case (info1, info2) of - (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2)) - (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2)) - (_, NoUnfolding) -> (id,occ, info1) - other -> (id,occ, info2) +modifyOutEnvItem :: (OutId, BinderInfo, Unfolding) -- Existing + -> (OutId, BinderInfo, Unfolding) -- New + -> (OutId, BinderInfo, Unfolding) +modifyOutEnvItem (_, _, info1) (id, occ, info2) + = (id, occ, case (info1, info2) of + (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2) + (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2) + (_, NoUnfolding) -> info1 + other -> info2) \end{code} @@ -419,16 +458,12 @@ isEvaluated other = False \begin{code} -mkSimplUnfoldingGuidance chkr out_id rhs - = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs - extendEnvGivenUnfolding :: SimplEnv -> OutId -> BinderInfo -> Unfolding -> SimplEnv extendEnvGivenUnfolding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps) out_id occ_info rhs_info = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) con_apps where - new_in_scope_ids = addToUFM_C modifyOutEnvItem in_scope_ids out_id - (out_id, occ_info, rhs_info) + new_in_scope_ids = addToUFM in_scope_ids out_id (out_id, occ_info, rhs_info) \end{code} @@ -598,7 +633,8 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) occ_info out_id rhs = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps where - new_in_scope_ids | okToInline (whnfOrBottom form) + new_in_scope_ids | okToInline out_id + (whnfOrBottom form) (couldBeSmallEnoughToInline out_id guidance) occ_info = env_with_unfolding @@ -648,12 +684,12 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) form = _scc_ "eegnr.form_sum" mkFormSummary rhs guidance = _scc_ "eegnr.guidance" - mkSimplUnfoldingGuidance chkr out_id rhs + calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs -- Attach a cost centre to the RHS if necessary rhs_w_cc | currentOrSubsumedCosts encl_cc || not (noCostCentreAttached (coreExprCc rhs)) = rhs | otherwise - = SCC encl_cc rhs + = Note (SCC encl_cc) rhs \end{code}