\begin{code}
module OccurAnal (
- occurAnalyseBinds, occurAnalyseGlobalExpr, occurAnalyseRule
+ occurAnalysePgm, occurAnalyseGlobalExpr, occurAnalyseRule,
) where
#include "HsVersions.h"
import CoreSyn
import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
-import Id ( isDataConId, isOneShotLambda, setOneShotLambda,
+import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
idOccInfo, setIdOccInfo,
- isExportedId, modifyIdInfo, idInfo, idArity,
- idSpecialisation, isLocalId,
+ isExportedId, idArity, idSpecialisation,
idType, idUnique, Id
)
-import IdInfo ( shortableIdInfo, copyIdInfo )
import BasicTypes ( OccInfo(..), isOneOcc )
import VarSet
import VarEnv
-import Type ( splitFunTy_maybe, splitForAllTys )
-import Maybes ( maybeToBool, orElse )
+import Type ( isFunTy, dropForAlls )
+import Maybes ( orElse )
import Digraph ( stronglyConnCompR, SCC(..) )
import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
import Unique ( Unique )
Here's the externally-callable interface:
\begin{code}
+occurAnalysePgm :: [CoreBind] -> [CoreBind]
+occurAnalysePgm binds
+ = snd (go (initOccEnv emptyVarSet) binds)
+ where
+ go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
+ go env []
+ = (emptyDetails, [])
+ go env (bind:binds)
+ = (final_usage, bind' ++ binds')
+ where
+ new_env = env `addNewCands` (bindersOf bind)
+ (bs_usage, binds') = go new_env binds
+ (final_usage, bind') = occAnalBind env bind bs_usage
+
occurAnalyseGlobalExpr :: CoreExpr -> CoreExpr
occurAnalyseGlobalExpr expr
= -- Top level expr, so no interesting free vars, and
%************************************************************************
%* *
-\subsection{Top level stuff}
-%* *
-%************************************************************************
-
-In @occAnalTop@ we do indirection-shorting. That is, if we have this:
-
- x_local = <expression>
- ...
- x_exported = loc
-
-where exp is exported, and loc is not, then we replace it with this:
-
- x_local = x_exported
- x_exported = <expression>
- ...
-
-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]
-
-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
- 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
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[OccurAnal-main]{Counting occurrences: main function}
%* *
%************************************************************************
where
(final_body_usage, tagged_binder) = tagBinder body_usage binder
- (rhs_usage, rhs') = occAnalRhs env binder rhs
+ (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
\end{code}
Dropping dead code for recursive bindings is done in a very simple way:
-- we didn't stupidly choose d as the loop breaker.
-- But we won't because constructor args are marked "Many".
- not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty))
- where
- (_, rho_ty) = splitForAllTys ty
+ not_fun_ty ty = not (isFunTy (dropForAlls ty))
\end{code}
@occAnalRhs@ deals with the question of bindings where the Id is marked
\begin{code}
occAnalRhs :: OccEnv
-> Id -> CoreExpr -- Binder and rhs
+ -- For non-recs the binder is alrady tagged
+ -- with occurrence info
-> (UsageDetails, CoreExpr)
occAnalRhs env id rhs
= (final_usage, rhs')
where
- (rhs_usage, rhs') = occAnal (rhsCtxt env) rhs
- -- Note that we use an rhsCtxt. This tells the occ anal that it's
- -- looking at an RHS, which has an effect in occAnalApp
+ (rhs_usage, rhs') = occAnal ctxt rhs
+ ctxt | certainly_inline id = env
+ | otherwise = rhsCtxt env
+ -- 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
--
-- But there's a problem. Consider
-- x1 = a0 : []
-- x2 = a1 : x1
-- x3 = a2 : x2
- -- g = f x2
+ -- g = f x3
-- First time round, it looks as if x1 and x2 occur as an arg of a
-- let-bound constructor ==> give them a many-occurrence.
-- But then x3 is inlined (unconditionally as it happens) and
-- next time round, x2 will be, and the next time round x1 will be
-- Result: multiple simplifier iterations. Sigh.
- -- Possible solution: use rhsCtxt for things that occur just once...
+ -- 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
-- [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
-- 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
env2 = env1 `addNewCands` binders -- Add in-scope binders
env_body = vanillaCtxt env2 -- Body is (no longer) an RhsContext
-occAnal env (Case scrut bndr alts)
+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') ->
+ case occAnal (vanillaCtxt env) scrut of { (scrut_usage, scrut') ->
-- No need for rhsCtxt
let
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
(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') }}
+ total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
where
alt_env = env `addNewCand` bndr
-- This is the *whole point* of the isRhsEnv predicate
final_args_uds
| isRhsEnv env,
- isDataConId fun || valArgCount args < idArity fun
+ isDataConWorkId fun || valArgCount args < idArity fun
= mapVarEnv markMany args_uds
| otherwise = args_uds
in
addNewCands :: OccEnv -> [Id] -> OccEnv
addNewCands (OccEnv cands encl ctxt) ids
- = OccEnv (cands `unionVarSet` mkVarSet ids) encl ctxt
+ = OccEnv (extendVarSetList cands ids) encl ctxt
addNewCand :: OccEnv -> Id -> OccEnv
addNewCand (OccEnv cands encl ctxt) id
= case go ctxt bndrs [] of
(new_ctxt, new_bndrs) -> (all is_one_shot new_bndrs, OccEnv cands encl new_ctxt, new_bndrs)
where
- is_one_shot b = isId b && isOneShotLambda b
+ is_one_shot b = isId b && isOneShotBndr b
go ctxt [] rev_bndrs = (ctxt, reverse rev_bndrs)