X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FOccurAnal.lhs;h=ad3eee0ce7345c4250a46921ac92f980649115bb;hb=2317c27bc0ca18dec43eacf87a6cf22cdf01f0f7;hp=bc45befbc2cfa1ed49bd152a1ac9e3ed11cca4be;hpb=d7c402a3cedbe49345a34f2e58a3f3050638dcb4;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index bc45bef..ad3eee0 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -12,22 +12,20 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule + occurAnalysePgm, occurAnalyseExpr ) where #include "HsVersions.h" import CoreSyn import CoreFVs ( idRuleVars ) -import CoreUtils ( exprIsTrivial ) +import CoreUtils ( exprIsTrivial, isDefaultAlt ) import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda, - idOccInfo, setIdOccInfo, - isExportedId, modifyIdInfo, idInfo, idArity, - idSpecialisation, isLocalId, + idOccInfo, setIdOccInfo, isLocalId, + isExportedId, idArity, idType, idUnique, Id ) -import IdInfo ( copyIdInfo ) -import BasicTypes ( OccInfo(..), isOneOcc ) +import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt ) import VarSet import VarEnv @@ -52,163 +50,22 @@ import Outputable Here's the externally-callable interface: \begin{code} -occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr -occurAnalyseGlobalExpr expr - = -- Top level expr, so no interesting free vars, and - -- discard occurence info returned - snd (occAnal (initOccEnv emptyVarSet) expr) - -occurAnalyseRule :: CoreRule -> CoreRule -occurAnalyseRule rule@(BuiltinRule _ _) = rule -occurAnalyseRule (Rule str act tpl_vars tpl_args rhs) - -- Add occ info to tpl_vars, rhs - = Rule str act tpl_vars' tpl_args rhs' +occurAnalysePgm :: [CoreBind] -> [CoreBind] +occurAnalysePgm binds + = snd (go initOccEnv binds) where - (rhs_uds, rhs') = occAnal (initOccEnv (mkVarSet tpl_vars)) rhs - (_, tpl_vars') = tagBinders rhs_uds tpl_vars -\end{code} - - -%************************************************************************ -%* * -\subsection{Top level stuff} -%* * -%************************************************************************ - -In @occAnalTop@ we do indirection-shorting. That is, if we have this: - - x_local = - ... - x_exported = loc - -where exp is exported, and loc is not, then we replace it with this: - - x_local = x_exported - x_exported = - ... - -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: -\begin{verbatim} - x_local = .... - x_exported1 = x_local - x_exported2 = x_local -==> - x_exported1 = .... - - x_exported2 = x_exported1 -\end{verbatim} - -We rely on prior eta reduction to simplify things like -\begin{verbatim} - x_exported = /\ tyvars -> x_local tyvars -==> - x_exported = x_local -\end{verbatim} -Hence,there's a possibility of leaving unchanged something like this: -\begin{verbatim} - x_local = .... - x_exported1 = x_local Int -\end{verbatim} -By the time we've thrown away the types in STG land this -could be eliminated. But I don't think it's very common -and it's dangerous to do this fiddling in STG land -because we might elminate a binding that's mentioned in the -unfolding for something. - -\begin{code} -occurAnalyseBinds :: [CoreBind] -> [CoreBind] + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) + go env [] + = (emptyDetails, []) + go env (bind:binds) + = (final_usage, bind' ++ binds') + where + (bs_usage, binds') = go env binds + (final_usage, bind') = occAnalBind env bind bs_usage -occurAnalyseBinds binds - = binds' - where - (_, _, binds') = go (initOccEnv emptyVarSet) binds - - go :: OccEnv -> [CoreBind] - -> (UsageDetails, -- Occurrence info - IdEnv Id, -- Indirection elimination info - -- 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, []) - - go env (bind : binds) - = let - new_env = env `addNewCands` (bindersOf bind) - (scope_usage, ind_env, binds') = go new_env binds - (final_usage, new_binds) = occAnalBind env (zapBind ind_env bind) scope_usage - -- NB: I zap before occur-analysing, so - -- I don't need to worry about getting the - -- occ info on the new bindings right. - in - case bind of - NonRec exported_id (Var local_id) - | shortMeOut ind_env exported_id local_id - -- Special case for eliminating indirections - -- Note: it's a shortcoming that this only works for - -- non-recursive bindings. Elminating indirections - -- makes perfect sense for recursive bindings too, but - -- it's more complicated to implement, so I haven't done so - -> (scope_usage, ind_env', binds') - where - ind_env' = extendVarEnv ind_env local_id exported_id - - other -> -- Ho ho! The normal case - (final_usage, ind_env, new_binds ++ binds') - - --- Deal with any indirections -zapBind ind_env (NonRec bndr rhs) - | bndr `elemVarEnv` ind_env = Rec (zap ind_env (bndr,rhs)) - -- The Rec isn't strictly necessary, but it's convenient -zapBind ind_env (Rec pairs) - | or [id `elemVarEnv` ind_env | (id,_) <- pairs] = Rec (concat (map (zap ind_env) pairs)) - -zapBind ind_env bind = bind - -zap ind_env pair@(local_id,rhs) - = case lookupVarEnv ind_env local_id of - Nothing -> [pair] - 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 --- 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 - True - -{- No longer needed - if shortableIdInfo (idInfo exported_id) -- Only if its IdInfo is 'shortable' - -- (see the defn of IdInfo.shortableIdInfo) - then True - else -#ifdef DEBUG - pprTrace "shortMeOut:" (ppr exported_id) -#endif - False --} - else - False +occurAnalyseExpr :: CoreExpr -> CoreExpr + -- Do occurrence analysis, and discard occurence info returned +occurAnalyseExpr expr = snd (occAnal initOccEnv expr) \end{code} @@ -288,13 +145,10 @@ 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 - binders = map fst pairs - rhs_env = env `addNewCands` binders - analysed_pairs :: [Details1] analysed_pairs = [ (bndr, rhs_usage, rhs') | (bndr, rhs) <- pairs, - let (rhs_usage, rhs') = occAnalRhs rhs_env bndr rhs + let (rhs_usage, rhs') = occAnalRhs env bndr rhs ] sccs :: [SCC (Node Details1)] @@ -465,9 +319,14 @@ reOrderRec env (CyclicSCC (bind : binds)) | 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 +-- NOT NEEDED ANY MORE [Feb06] +-- We make all rules available in all bindings, by substituting +-- the IdInfo before looking at any RHSs. I'm just leaving this +-- snippet in as a commment so we can find it again if necessary. +-- +-- | not (isEmptySpecInfo (idSpecialisation bndr)) = 1 +-- -- Avoid things with specialisations; we'd like +-- -- to take advantage of them in the subsequent bindings | otherwise = 0 @@ -511,7 +370,7 @@ occAnalRhs env id rhs where (rhs_usage, rhs') = occAnal ctxt rhs ctxt | certainly_inline id = env - | otherwise = rhsCtxt env + | otherwise = rhsCtxt -- Note that we generally use an rhsCtxt. This tells the occ anal n -- that it's looking at an RHS, which has an effect in occAnalApp -- @@ -528,8 +387,8 @@ occAnalRhs env id rhs -- Crude solution: use rhsCtxt for things that occur just once... certainly_inline id = case idOccInfo id of - OneOcc in_lam one_br -> not in_lam && one_br - other -> False + OneOcc in_lam one_br _ -> not in_lam && one_br + other -> False -- [March 98] A new wrinkle is that if the binder has specialisations inside -- it then we count the specialised Ids as "extra rhs's". That way @@ -537,11 +396,16 @@ occAnalRhs env id rhs -- dies (because it isn't referenced any more), then the children will -- die too unless they are already referenced directly. - final_usage = foldVarSet add rhs_usage (idRuleVars id) + final_usage = addRuleUsage rhs_usage id + +addRuleUsage :: UsageDetails -> Id -> UsageDetails +-- Add the usage from RULES in Id to the usage +addRuleUsage usage id + = foldVarSet add usage (idRuleVars id) + where 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} Expressions @@ -553,20 +417,13 @@ occAnal :: OccEnv CoreExpr) occAnal env (Type t) = (emptyDetails, Type t) - -occAnal env (Var v) - = (var_uds, Var v) - where - var_uds | isCandidate env v = unitVarEnv v oneOcc - | otherwise = emptyDetails - +occAnal env (Var v) = (mkOneOcc env v False, Var v) -- At one stage, I gathered the idRuleVars for v here too, -- which in a way is the right thing to do. - -- But that went wrong right after specialisation, when + -- Btu that went wrong right after specialisation, when -- the *occurrences* of the overloaded function didn't have any -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. - \end{code} We regard variables that occur as constructor arguments as "dangerousToDup": @@ -643,15 +500,15 @@ occAnal env expr@(Lam _ _) (really_final_usage, mkLams tagged_binders body') } where - (binders, body) = collectBinders expr - (linear, env1, _) = oneShotGroup env binders - env2 = env1 `addNewCands` binders -- Add in-scope binders - env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext + env_body = vanillaCtxt -- Body is (no longer) an RhsContext + (binders, body) = collectBinders expr + binders' = oneShotGroup env binders + linear = all is_one_shot binders' + is_one_shot b = isId b && isOneShotBndr b occAnal env (Case scrut bndr ty alts) - = case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') -> - case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') -> - -- No need for rhsCtxt + = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> + case mapAndUnzip (occAnalAlt env bndr) alts of { (alts_usage_s, alts') -> let alts_usage = foldr1 combineAltsUsageDetails alts_usage_s alts_usage' = addCaseBndrUsage alts_usage @@ -660,8 +517,6 @@ occAnal env (Case scrut bndr ty alts) in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty 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. @@ -673,18 +528,22 @@ occAnal env (Case scrut bndr ty alts) Nothing -> usage Just occ -> extendVarEnv usage bndr (markMany occ) + occ_anal_scrut (Var v) (alt1 : other_alts) + | not (null other_alts) || not (isDefaultAlt alt1) + = (mkOneOcc env v True, Var v) + occ_anal_scrut scrut alts = occAnal vanillaCtxt scrut + -- No need for rhsCtxt + occAnal env (Let bind body) - = case occAnal new_env body of { (body_usage, body') -> + = case occAnal env body of { (body_usage, body') -> case occAnalBind env bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} - where - new_env = env `addNewCands` (bindersOf bind) occAnalArgs env args = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') -> (foldr combineUsageDetails emptyDetails arg_uds_s, args')} where - arg_env = vanillaCtxt env + arg_env = vanillaCtxt \end{code} Applications are dealt with specially because we want @@ -711,10 +570,7 @@ occAnalApp env (Var fun, args) is_rhs (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') } where fun_uniq = idUnique fun - - fun_uds | isCandidate env fun = unitVarEnv fun oneOcc - | otherwise = emptyDetails - + fun_uds = mkOneOcc env fun (valArgCount args > 0) 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 @@ -750,7 +606,7 @@ appSpecial :: OccEnv appSpecial env n ctxt args = go n args where - arg_env = vanillaCtxt env + arg_env = vanillaCtxt go n [] = (emptyDetails, []) -- Too few args @@ -778,7 +634,7 @@ If e turns out to be (e1,e2) we indeed get something like \begin{code} occAnalAlt env case_bndr (con, bndrs, rhs) - = case occAnal (env `addNewCands` bndrs) rhs of { (rhs_usage, rhs') -> + = case occAnal env rhs of { (rhs_usage, rhs') -> let (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs @@ -798,8 +654,7 @@ occAnalAlt env case_bndr (con, bndrs, rhs) \begin{code} data OccEnv - = OccEnv IdSet -- In-scope Ids; we gather info about these only - OccEncl -- Enclosing context information + = OccEnv OccEncl -- Enclosing context information CtxtTy -- Tells about linearity -- OccEncl is used to control whether to inline into constructor arguments @@ -826,42 +681,28 @@ type CtxtTy = [Bool] -- be applied many times; but when it is, -- the CtxtTy inside applies -initOccEnv :: VarSet -> OccEnv -initOccEnv vars = OccEnv vars OccRhs [] - -isRhsEnv (OccEnv _ OccRhs _) = True -isRhsEnv (OccEnv _ OccVanilla _) = False +initOccEnv :: OccEnv +initOccEnv = OccEnv OccRhs [] -isCandidate :: OccEnv -> Id -> Bool -isCandidate (OccEnv cands encl _) id = id `elemVarSet` cands +vanillaCtxt = OccEnv OccVanilla [] +rhsCtxt = OccEnv OccRhs [] -addNewCands :: OccEnv -> [Id] -> OccEnv -addNewCands (OccEnv cands encl ctxt) ids - = OccEnv (extendVarSetList cands ids) encl ctxt - -addNewCand :: OccEnv -> Id -> OccEnv -addNewCand (OccEnv cands encl ctxt) id - = OccEnv (extendVarSet cands id) encl ctxt +isRhsEnv (OccEnv OccRhs _) = True +isRhsEnv (OccEnv OccVanilla _) = False setCtxt :: OccEnv -> CtxtTy -> OccEnv -setCtxt (OccEnv cands encl _) ctxt = OccEnv cands encl ctxt - -oneShotGroup :: OccEnv -> [CoreBndr] -> (Bool, OccEnv, [CoreBndr]) - -- True <=> this is a one-shot linear lambda group - -- The [CoreBndr] are the binders. +setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt +oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr] -- 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 cands encl ctxt) bndrs - = case go ctxt bndrs [] of - (new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs) +oneShotGroup (OccEnv encl ctxt) bndrs + = go ctxt bndrs [] where - is_one_shot b = isId b && isOneShotBndr b - - go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs) + go ctxt [] rev_bndrs = reverse rev_bndrs go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs | isId bndr = go ctxt bndrs (bndr':rev_bndrs) @@ -871,12 +712,8 @@ oneShotGroup (OccEnv cands encl ctxt) bndrs go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs) - -vanillaCtxt (OccEnv cands _ _) = OccEnv cands OccVanilla [] -rhsCtxt (OccEnv cands _ _) = OccEnv cands OccRhs [] - -addAppCtxt (OccEnv cands encl ctxt) args - = OccEnv cands encl (replicate (valArgCount args) True ++ ctxt) +addAppCtxt (OccEnv encl ctxt) args + = OccEnv encl (replicate (valArgCount args) True ++ ctxt) \end{code} %************************************************************************ @@ -954,8 +791,10 @@ setBinderOcc usage bndr %************************************************************************ \begin{code} -oneOcc :: OccInfo -oneOcc = OneOcc False True +mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails +mkOneOcc env id int_cxt + | isLocalId id = unitVarEnv id (OneOcc False True int_cxt) + | otherwise = emptyDetails markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo @@ -964,8 +803,8 @@ markMany other = NoOccInfo markInsideSCC occ = markMany occ -markInsideLam (OneOcc _ one_br) = OneOcc True one_br -markInsideLam occ = occ +markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt +markInsideLam occ = occ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo @@ -978,10 +817,11 @@ addOccInfo info1 info2 = NoOccInfo orOccInfo IAmDead info2 = info2 orOccInfo info1 IAmDead = info1 -orOccInfo (OneOcc in_lam1 one_branch1) - (OneOcc in_lam2 one_branch2) +orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1) + (OneOcc in_lam2 one_branch2 int_cxt2) = OneOcc (in_lam1 || in_lam2) False -- False, because it occurs in both branches + (int_cxt1 && int_cxt2) orOccInfo info1 info2 = NoOccInfo \end{code}