X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FsimplCore%2FOccurAnal.lhs;h=750e2b6cde3430a3475e727bb406a0dac1ecb2f7;hb=972d6442ee3a6ee0a5fa20655d882e0041646892;hp=87927ece4821662041495ee0492cbd1d73ee5e6c;hpb=cfcebde74cf826af12143a92bcffa8c995eee135;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 87927ec..750e2b6 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -12,38 +12,33 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr, - markBinderInsideLambda, tagBinders, - UsageDetails + occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule ) where #include "HsVersions.h" -import BinderInfo -import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial ) -import Const ( Con(..), Literal(..) ) -import Id ( isSpecPragmaId, - getInlinePragma, setInlinePragma, +import Id ( isDataConId, isOneShotLambda, setOneShotLambda, + idOccInfo, setIdOccInfo, isExportedId, modifyIdInfo, idInfo, - getIdSpecialisation, + idSpecialisation, isLocalId, idType, idUnique, Id ) -import IdInfo ( InlinePragInfo(..), OccInfo(..), copyIdInfo ) +import IdInfo ( OccInfo(..), shortableIdInfo, copyIdInfo ) import VarSet import VarEnv -import ThinAir ( noRepStrIds, noRepIntegerIds ) -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, count ) +import Util ( zipWithEqual, mapAndUnzip ) +import FastTypes import Outputable \end{code} @@ -59,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 @@ -72,6 +67,15 @@ occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and -- discard occurence info returned snd (occurAnalyseExpr (\_ -> False) expr) + +occurAnalyseRule :: CoreRule -> CoreRule +occurAnalyseRule rule@(BuiltinRule _) = rule +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 isLocalId rhs + (_, tpl_vars') = tagBinders rhs_uds tpl_vars \end{code} @@ -83,22 +87,20 @@ occurAnalyseGlobalExpr expr 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: @@ -140,7 +142,10 @@ occurAnalyseBinds binds go :: OccEnv -> [CoreBind] -> (UsageDetails, -- Occurrence info IdEnv Id, -- Indirection elimination info - [CoreBind]) + -- Maps local-id -> exported-id, but it embodies + -- bindings of the form exported-id = local-id in + -- the argument to go + [CoreBind]) -- Occ-analysed bindings, less the exported-id=local-id ones go env [] = (emptyDetails, emptyVarEnv, []) @@ -166,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 [] @@ -182,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} @@ -282,8 +294,6 @@ It isn't easy to do a perfect job in one blow. Consider occAnalBind env (Rec pairs) body_usage = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs where - pp_item (_, bndr, _) = ppr bndr - binders = map fst pairs rhs_env = env `addNewCands` binders @@ -300,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 ] @@ -416,7 +426,7 @@ reOrderRec env (AcyclicSCC (bind, _, _)) = [bind] -- Common case of simple self-recursion reOrderRec env (CyclicSCC [bind]) - = [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)] + = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] where ((tagged_bndr, rhs), _, _) = bind @@ -425,7 +435,7 @@ reOrderRec env (CyclicSCC (bind : binds)) -- do SCC analysis on the rest, and recursively sort them out concat (map (reOrderRec env) (stronglyConnCompR unchosen)) ++ - [(setInlinePragma tagged_bndr IAmALoopBreaker, rhs)] + [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] where (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds @@ -447,21 +457,31 @@ reOrderRec env (CyclicSCC (bind : binds)) score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker score ((bndr, rhs), _, _) - | exprIsTrivial rhs && - not (isExportedId bndr) = 3 -- Practically certain to be inlined - | inlineCandidate bndr rhs = 3 -- Likely to be inlined - | not_fun_ty (idType bndr) = 2 -- Data types help with cases - | not (isEmptyCoreRules (getIdSpecialisation bndr)) = 1 + | exprIsTrivial rhs = 4 -- Practically certain to be inlined + -- Used to have also: && not (isExportedId bndr) + -- But I found this sometimes cost an extra iteration when we have + -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } + -- where df is the exported dictionary. Then df makes a really + -- bad choice for loop breaker + + | not_fun_ty (idType bndr) = 3 -- Data types help with cases + -- This used to have a lower score than inlineCandidate, but + -- it's *really* helpful if dictionaries get inlined fast, + -- so I'm experimenting with giving higher priority to data-typed things + + | inlineCandidate bndr rhs = 2 -- Likely to be inlined + + | not (isEmptyCoreRules (idSpecialisation bndr)) = 1 -- Avoid things with specialisations; we'd like -- to take advantage of them in the subsequent bindings + | otherwise = 0 inlineCandidate :: Id -> CoreExpr -> Bool inlineCandidate id (Note InlineMe _) = True - inlineCandidate id rhs = case getInlinePragma id of - IMustBeINLINEd -> True - ICanSafelyBeINLINEd _ _ -> True - other -> False + inlineCandidate id rhs = case idOccInfo id of + OneOcc _ _ -> True + other -> False -- Real example (the Enum Ordering instance from PrelBase): -- rec f = \ x -> case d of (p,q,r) -> p x @@ -506,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} @@ -524,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, @@ -552,35 +572,7 @@ If we aren't careful we duplicate the (expensive x) call! Constructors are rather like lambdas in this way. \begin{code} - -- For NoRep literals we have to report an occurrence of - -- the things which tidyCore will later add, so that when - -- we are compiling the very module in which those thin-air Ids - -- are defined we have them in scope! -occAnal env expr@(Con (Literal lit) args) - = ASSERT( null args ) - (mk_lit_uds lit, expr) - where - mk_lit_uds (NoRepStr _ _) = try noRepStrIds - mk_lit_uds (NoRepInteger _ _) = try noRepIntegerIds - mk_lit_uds lit = emptyDetails - - try vs = foldr add emptyDetails vs - add v uds | isCandidate env v = extendVarEnv uds v funOccZero - | otherwise = uds - -occAnal env (Con con args) - = case occAnalArgs env args of { (arg_uds, args') -> - let - -- We mark the free vars of the argument of a constructor as "many" - -- This means that nothing gets inlined into a constructor argument - -- position, which is what we want. Typically those constructor - -- arguments are just variables, or trivial expressions. - final_arg_uds = case con of - DataCon _ -> mapVarEnv markMany arg_uds - other -> arg_uds - in - (final_arg_uds, Con con args') - } +occAnal env expr@(Lit lit) = (emptyDetails, expr) \end{code} \begin{code} @@ -626,6 +618,10 @@ occAnal env expr@(Lam _ _) = case occAnal (env_body `addNewCands` binders) body of { (body_usage, body') -> let (final_usage, tagged_binders) = tagBinders body_usage binders + -- URGH! Sept 99: we don't seem to be able to use binders' here, because + -- we get linear-typed things in the resulting program that we can't handle yet. + -- (e.g. PrelShow) TODO + really_final_usage = if linear then final_usage else @@ -634,21 +630,33 @@ occAnal env expr@(Lam _ _) (really_final_usage, mkLams tagged_binders body') } where - (binders, body) = collectBinders expr - (linear, env_body) = getCtxt env (count isId binders) + (binders, body) = collectBinders expr + (linear, env_body, _) = oneShotGroup env binders occAnal env (Case scrut bndr alts) = case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts') -> case occAnal (zapCtxt env) scrut of { (scrut_usage, scrut') -> let alts_usage = foldr1 combineAltsUsageDetails alts_usage_s - (alts_usage1, tagged_bndr) = tagBinder alts_usage bndr + alts_usage' = addCaseBndrUsage alts_usage + (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr total_usage = scrut_usage `combineUsageDetails` alts_usage1 in total_usage `seq` (total_usage, Case scrut' tagged_bndr alts') }} where alt_env = env `addNewCand` bndr + -- The case binder gets a usage of either "many" or "dead", never "one". + -- Reason: we like to inline single occurrences, to eliminate a binding, + -- but inlining a case binder *doesn't* eliminate a binding. + -- We *don't* want to transform + -- case x of w { (p,q) -> f w } + -- into + -- case x of w { (p,q) -> f (p,q) } + addCaseBndrUsage usage = case lookupVarEnv usage bndr of + Nothing -> usage + Just occ -> extendVarEnv usage bndr (markMany occ) + occAnal env (Let bind body) = case occAnal new_env body of { (body_usage, body') -> case occAnalBind env bind body_usage of { (final_usage, new_binds) -> @@ -677,15 +685,24 @@ 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 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args + + | isDataConId fun = case occAnalArgs env args of + (arg_uds, args') -> (mapVarEnv markMany arg_uds, args') + -- We mark the free vars of the argument of a constructor as "many" + -- This means that nothing gets inlined into a constructor argument + -- position, which is what we want. Typically those constructor + -- arguments are just variables, or trivial expressions. + | otherwise = occAnalArgs env args + occAnalApp env (fun, args) = case occAnal (zapCtxt env) fun of { (fun_uds, fun') -> case occAnalArgs env args of { (args_uds, args') -> @@ -764,35 +781,53 @@ addNewCand (OccEnv ifun cands ctxt) id setCtxt :: OccEnv -> CtxtTy -> OccEnv setCtxt (OccEnv ifun cands _) ctxt = OccEnv ifun cands ctxt -getCtxt :: OccEnv -> Int -> (Bool, OccEnv) -- True <=> this is a linear lambda - -- The Int is the number of lambdas -getCtxt env@(OccEnv ifun cands []) n = (False, env) -getCtxt (OccEnv ifun cands ctxt) n = (and (take n ctxt), OccEnv ifun cands (drop n ctxt)) - -- Only return True if *all* the lambdas are linear +oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr]) + -- True <=> this is a one-shot linear lambda group + -- The [CoreBndr] are the binders. + + -- The result binders have one-shot-ness set that they might not have had originally. + -- This happens in (build (\cn -> e)). Here the occurrence analyser + -- linearity context knows that c,n are one-shot, and it records that fact in + -- the binder. This is useful to guide subsequent float-in/float-out tranformations + +oneShotGroup (OccEnv ifun cands ctxt) bndrs + = case go ctxt bndrs [] of + (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv ifun cands new_ctxt, new_bndrs) + where + is_one_shot b = isId b && isOneShotLambda b + + go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs) + + go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs + | isId bndr = go ctxt bndrs (bndr':rev_bndrs) + where + bndr' | lin_ctxt = setOneShotLambda bndr + | otherwise = bndr + + go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_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 @@ -804,7 +839,7 @@ tagBinders :: UsageDetails -- Of scope tagBinders usage binders = let usage' = usage `delVarEnvList` binders - uss = map (setBinderPrag usage) binders + uss = map (setBinderOcc usage) binders in usage' `seq` (usage', uss) @@ -816,56 +851,61 @@ tagBinder :: UsageDetails -- Of scope tagBinder usage binder = let usage' = usage `delVarEnv` binder - binder' = setBinderPrag usage binder + binder' = setBinderOcc usage binder in usage' `seq` (usage', binder') +setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr +setBinderOcc usage bndr + | isTyVar bndr = bndr + | 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 + where + occ_info = lookupVarEnv usage bndr `orElse` IAmDead +\end{code} -setBinderPrag :: UsageDetails -> CoreBndr -> CoreBndr -setBinderPrag usage bndr - | isTyVar bndr - = bndr - | otherwise - = case old_prag of - NoInlinePragInfo -> new_bndr - IAmDead -> new_bndr -- The next three are annotations - ICanSafelyBeINLINEd _ _ -> new_bndr -- from the previous iteration of - IAmALoopBreaker -> new_bndr -- the occurrence analyser +%************************************************************************ +%* * +\subsection{Operations over OccInfo} +%* * +%************************************************************************ + +\begin{code} +oneOcc :: OccInfo +oneOcc = OneOcc False True - other | its_now_dead -> new_bndr -- Overwrite the others iff it's now dead - | otherwise -> bndr +markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo - where - old_prag = getInlinePragma bndr - new_bndr = setInlinePragma bndr new_prag +markMany IAmDead = IAmDead +markMany other = NoOccInfo - its_now_dead = case new_prag of - IAmDead -> True - other -> False +markInsideSCC occ = markMany occ - new_prag = occInfoToInlinePrag occ_info +markInsideLam (OneOcc _ one_br) = OneOcc True one_br +markInsideLam occ = occ - occ_info - | isExportedId bndr = noBinderInfo - -- Don't use local usage info for visible-elsewhere things - -- But NB that we do set NoInlinePragma for exported things - -- thereby nuking any IAmALoopBreaker from a previous pass. +addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo - | otherwise = case lookupVarEnv usage bndr of - Nothing -> deadOccurrence - Just info -> info +addOccInfo IAmDead info2 = info2 +addOccInfo info1 IAmDead = info1 +addOccInfo info1 info2 = NoOccInfo -markBinderInsideLambda :: CoreBndr -> CoreBndr -markBinderInsideLambda bndr - | isTyVar bndr - = bndr +-- (orOccInfo orig new) is used +-- when combining occurrence info from branches of a case - | otherwise - = case getInlinePragma bndr of - ICanSafelyBeINLINEd not_in_lam nalts - -> bndr `setInlinePragma` ICanSafelyBeINLINEd InsideLam nalts - other -> bndr +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}