X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FOccurAnal.lhs;h=750e2b6cde3430a3475e727bb406a0dac1ecb2f7;hb=972d6442ee3a6ee0a5fa20655d882e0041646892;hp=b7d7c22f6bc17448aa11bd3a0950b73c0fde9d21;hpb=fe69f3c1d6062b90635963aa414c33951bf18427;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index b7d7c22..750e2b6 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -17,28 +17,28 @@ module OccurAnal ( #include "HsVersions.h" -import BinderInfo import CoreSyn import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial ) -import Id ( isSpecPragmaId, isDataConId, isOneShotLambda, setOneShotLambda, +import Id ( isDataConId, isOneShotLambda, setOneShotLambda, idOccInfo, setIdOccInfo, isExportedId, modifyIdInfo, idInfo, - idSpecialisation, + idSpecialisation, isLocalId, idType, idUnique, Id ) -import IdInfo ( OccInfo(..), insideLam, copyIdInfo ) +import IdInfo ( OccInfo(..), shortableIdInfo, copyIdInfo ) import VarSet import VarEnv -import Name ( isLocallyDefined ) import Type ( splitFunTy_maybe, splitForAllTys ) -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, orElse ) import Digraph ( stronglyConnCompR, SCC(..) ) -import Unique ( u2i, buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) +import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) +import Unique ( u2i ) import UniqFM ( keysUFM ) import Util ( zipWithEqual, mapAndUnzip ) +import FastTypes import Outputable \end{code} @@ -54,7 +54,7 @@ Here's the externally-callable interface: \begin{code} occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting -> CoreExpr - -> (IdEnv BinderInfo, -- Occ info for interesting free vars + -> (IdEnv OccInfo, -- Occ info for interesting free vars CoreExpr) occurAnalyseExpr interesting expr @@ -74,7 +74,7 @@ occurAnalyseRule (Rule str tpl_vars tpl_args rhs) -- Add occ info to tpl_vars, rhs = Rule str tpl_vars' tpl_args rhs' where - (rhs_uds, rhs') = occurAnalyseExpr isLocallyDefined rhs + (rhs_uds, rhs') = occurAnalyseExpr isLocalId rhs (_, tpl_vars') = tagBinders rhs_uds tpl_vars \end{code} @@ -87,20 +87,20 @@ occurAnalyseRule (Rule str tpl_vars tpl_args rhs) In @occAnalTop@ we do indirection-shorting. That is, if we have this: - loc = + x_local = ... - exp = loc + x_exported = loc where exp is exported, and loc is not, then we replace it with this: - loc = exp - exp = + x_local = x_exported + x_exported = ... -Without this we never get rid of the exp = loc thing. This save a -gratuitous jump (from \tr{x_exported} to \tr{x_local}), and makes -strictness information propagate better. This used to happen in the -final phase, but it's tidier to do it here. +Without this we never get rid of the x_exported = x_local thing. This +save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and +makes strictness information propagate better. This used to happen in +the final phase, but it's tidier to do it here. If more than one exported thing is equal to a local thing (i.e., the local thing really is shared), then we do one only: @@ -171,9 +171,9 @@ occurAnalyseBinds binds ind_env' = extendVarEnv ind_env local_id exported_id other -> -- Ho ho! The normal case - (final_usage, ind_env, new_binds ++ binds') + (final_usage, ind_env, new_binds ++ binds') -initialTopEnv = OccEnv isLocallyDefined -- Anything local is interesting +initialTopEnv = OccEnv isLocalId -- Anything local is interesting emptyVarSet [] @@ -187,27 +187,34 @@ zapBind ind_env (Rec pairs) zapBind ind_env bind = bind -zap ind_env pair@(bndr,rhs) - = case lookupVarEnv ind_env bndr of +zap ind_env pair@(local_id,rhs) + = case lookupVarEnv ind_env local_id of Nothing -> [pair] - Just exported_id -> [(bndr, Var exported_id), - (exported_id_w_info, rhs)] - where - exported_id_w_info = modifyIdInfo (copyIdInfo (idInfo bndr)) exported_id - -- See notes with copyIdInfo about propagating IdInfo from - -- one to t'other + Just exported_id -> [(local_id, Var exported_id), + (exported_id', rhs)] + where + exported_id' = modifyIdInfo (copyIdInfo (idInfo local_id)) exported_id shortMeOut ind_env exported_id local_id - = isExportedId exported_id && -- Only if this is exported - - isLocallyDefined local_id && -- Only if this one is defined in this - -- module, so that we *can* change its - -- binding to be the exported thing! - - not (isExportedId local_id) && -- Only if this one is not itself exported, - -- since the transformation will nuke it - - not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for +-- The if-then-else stuff is just so I can get a pprTrace to see +-- how often I don't get shorting out becuase of IdInfo stuff + = if isExportedId exported_id && -- Only if this is exported + + isLocalId local_id && -- Only if this one is defined in this + -- module, so that we *can* change its + -- binding to be the exported thing! + + not (isExportedId local_id) && -- Only if this one is not itself exported, + -- since the transformation will nuke it + + not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for + then + if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable' + -- (see the defn of IdInfo.shortableIdInfo) + then True + else pprTrace "shortMeOut:" (ppr exported_id) False + else + False \end{code} @@ -303,7 +310,7 @@ occAnalBind env (Rec pairs) body_usage ---- stuff for dependency analysis of binds ------------------------------- edges :: [Node Details1] edges = _scc_ "occAnalBind.assoc" - [ (details, IBOX(u2i (idUnique id)), edges_from rhs_usage) + [ (details, iBox (u2i (idUnique id)), edges_from rhs_usage) | details@(id, rhs_usage, rhs) <- analysed_pairs ] @@ -519,7 +526,7 @@ occAnalRhs env id rhs -- die too unless they are already referenced directly. final_usage = foldVarSet add rhs_usage (idRuleVars id) - add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info + add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info -- (i.e manyOcc) because many copies -- of the specialised thing can appear \end{code} @@ -537,7 +544,7 @@ occAnal env (Type t) = (emptyDetails, Type t) occAnal env (Var v) = (var_uds, Var v) where - var_uds | isCandidate env v = unitVarEnv v funOccZero + var_uds | isCandidate env v = unitVarEnv v oneOcc | otherwise = emptyDetails -- At one stage, I gathered the idRuleVars for v here too, @@ -678,7 +685,7 @@ occAnalApp env (Var fun, args) where fun_uniq = idUnique fun - fun_uds | isCandidate env fun = unitVarEnv fun funOccZero + fun_uds | isCandidate env fun = unitVarEnv fun oneOcc | otherwise = emptyDetails args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args @@ -803,26 +810,24 @@ oneShotGroup (OccEnv ifun cands ctxt) bndrs zapCtxt env@(OccEnv ifun cands []) = env zapCtxt (OccEnv ifun cands _ ) = OccEnv ifun cands [] -type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage +type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage combineUsageDetails, combineAltsUsageDetails :: UsageDetails -> UsageDetails -> UsageDetails combineUsageDetails usage1 usage2 - = plusVarEnv_C addBinderInfo usage1 usage2 + = plusVarEnv_C addOccInfo usage1 usage2 combineAltsUsageDetails usage1 usage2 - = plusVarEnv_C orBinderInfo usage1 usage2 + = plusVarEnv_C orOccInfo usage1 usage2 -addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails +addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails addOneOcc usage id info - = plusVarEnv_C addBinderInfo usage (unitVarEnv id info) + = plusVarEnv_C addOccInfo usage (unitVarEnv id info) -- ToDo: make this more efficient emptyDetails = (emptyVarEnv :: UsageDetails) -unitDetails id info = (unitVarEnv id info :: UsageDetails) - usedIn :: Id -> UsageDetails -> Bool v `usedIn` details = isExportedId v || v `elemVarEnv` details @@ -850,23 +855,57 @@ tagBinder usage binder in usage' `seq` (usage', binder') - setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr setBinderOcc usage bndr | isTyVar bndr = bndr - | isExportedId bndr - = -- Don't use local usage info for visible-elsewhere things - -- BUT *do* erase any IAmALoopBreaker annotation, because we're - -- about to re-generate it and it shouldn't be "sticky" - case idOccInfo bndr of - NoOccInfo -> bndr - other -> setIdOccInfo bndr NoOccInfo + | isExportedId bndr = case idOccInfo bndr of + NoOccInfo -> bndr + other -> setIdOccInfo bndr NoOccInfo + -- Don't use local usage info for visible-elsewhere things + -- BUT *do* erase any IAmALoopBreaker annotation, because we're + -- about to re-generate it and it shouldn't be "sticky" - | otherwise = setIdOccInfo bndr occ_info + | otherwise = setIdOccInfo bndr occ_info where - occ_info = case lookupVarEnv usage bndr of - Nothing -> IAmDead - Just info -> binderInfoToOccInfo info + occ_info = lookupVarEnv usage bndr `orElse` IAmDead +\end{code} + + +%************************************************************************ +%* * +\subsection{Operations over OccInfo} +%* * +%************************************************************************ + +\begin{code} +oneOcc :: OccInfo +oneOcc = OneOcc False True + +markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo + +markMany IAmDead = IAmDead +markMany other = NoOccInfo + +markInsideSCC occ = markMany occ + +markInsideLam (OneOcc _ one_br) = OneOcc True one_br +markInsideLam occ = occ + +addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo + +addOccInfo IAmDead info2 = info2 +addOccInfo info1 IAmDead = info1 +addOccInfo info1 info2 = NoOccInfo + +-- (orOccInfo orig new) is used +-- when combining occurrence info from branches of a case + +orOccInfo IAmDead info2 = info2 +orOccInfo info1 IAmDead = info1 +orOccInfo (OneOcc in_lam1 one_branch1) + (OneOcc in_lam2 one_branch2) + = OneOcc (in_lam1 || in_lam2) + False -- False, because it occurs in both branches -funOccZero = funOccurrence 0 +orOccInfo info1 info2 = NoOccInfo \end{code}