%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%* *
%* *
%************************************************************************
-The occurrence analyser analyses the way in which variables are used
-in their scope, and pins that information on the binder. It does {\em
-not} take any strategic decisions about what to do as a result (eg
-discard binding, inline binding etc). That's the job of the
-simplifier.
-
-The occurrence analyser {\em simply} records usage information. That is,
-it pins on each binder info on how that binder occurs in its scope.
-
-Any uses within the RHS of a let(rec) binding for a variable which is
-itself unused are ignored. For example:
-@
- let x = ...
- y = ...x...
- in
- x+1
-@
-Here, y is unused, so x will be marked as appearing just once.
-
-An exported Id gets tagged as ManyOcc.
-
-IT MUST OBSERVE SCOPING: CANNOT assume unique binders.
-
-Lambdas
-~~~~~~~
-The occurrence analyser marks each binder in a lambda the same way.
-Thus:
- \ x y -> f y x
-will have both x and y marked as single occurrence, and *not* dangerous-to-dup.
-Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup,
-but the simplifer very carefully takes care of this special case.
-(See the CoLam case in simplExpr.)
-
-Why? Because typically applications are saturated, in which case x is *not*
-dangerous-to-dup.
-
-Things to muse upon
-~~~~~~~~~~~~~~~~~~~
-
-There *is* a reason not to substitute for
-variables applied to types: it can undo the effect of floating
-Consider:
-\begin{verbatim}
- c = /\a -> e
- f = /\b -> let d = c b
- in \ x::b -> ...
-\end{verbatim}
-Here, inlining c would be a Bad Idea.
-
-At present I've set it up so that the "inside-lambda" flag sets set On for
-type-lambdas too, which effectively prevents such substitutions. I don't *think*
-it disables any interesting ones either.
+The occurrence analyser re-typechecks a core expression, returning a new
+core expression with (hopefully) improved usage information.
\begin{code}
#include "HsVersions.h"
module OccurAnal (
- occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
-
- -- and to make the interface self-sufficient...
- CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
- PlainCoreProgram(..), PlainCoreExpr(..),
- SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
+ occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
) where
-IMPORT_Trace
-import Outputable -- ToDo: rm; debugging
-import Pretty
-
-import PlainCore -- the stuff we read...
-import TaggedCore -- ... and produce Simplifiable*
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(IdLoop) -- paranoia
-import AbsUniType
import BinderInfo
-import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) )
+import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
+import CoreSyn
import Digraph ( stronglyConnComp )
-import Id ( eqId, idWantsToBeINLINEd, isConstMethodId,
- isSpecPragmaId_maybe, SpecInfo )
-import IdEnv
-import Maybes
-import UniqSet
-import Util
+import Id ( idWantsToBeINLINEd, isConstMethodId,
+ emptyIdSet, unionIdSets, mkIdSet,
+ unitIdSet, elementOfIdSet,
+ addOneToIdSet, IdSet(..),
+ nullIdEnv, unitIdEnv, combineIdEnvs,
+ delOneFromIdEnv, delManyFromIdEnv,
+ mapIdEnv, lookupIdEnv, IdEnv(..),
+ GenId{-instance Eq-}
+ )
+import Maybes ( maybeToBool )
+import Name ( isExported )
+import Outputable ( Outputable(..){-instance * (,) -} )
+import PprCore
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
+import Pretty ( ppAboves )
+import TyVar ( GenTyVar{-instance Eq-} )
+import Unique ( Unique{-instance Eq-} )
+import Util ( assoc, zipEqual, pprTrace, panic )
+
+isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
\end{code}
%************************************************************************
\begin{code}
-data OccEnv = OccEnv
- Bool -- Keep-unused-bindings flag
- -- False <=> OK to chuck away binding
- -- and ignore occurrences within it
- Bool -- Keep-spec-pragma-ids flag
- -- False <=> OK to chuck away spec pragma bindings
- -- and ignore occurrences within it
- Bool -- Keep-conjurable flag
- -- False <=> OK to throw away *dead*
- -- "conjurable" Ids; at the moment, that
- -- *only* means constant methods, which
- -- are top-level. A use of a "conjurable"
- -- Id may appear out of thin air -- e.g.,
- -- specialiser conjuring up refs to const
- -- methods.
- Bool -- IgnoreINLINEPragma flag
- -- False <=> OK to use INLINEPragma information
- -- True <=> ignore INLINEPragma information
- (UniqSet Id) -- Candidates
+data OccEnv =
+ OccEnv
+ Bool -- Keep-unused-bindings flag
+ -- False <=> OK to chuck away binding
+ -- and ignore occurrences within it
+ Bool -- Keep-spec-pragma-ids flag
+ -- False <=> OK to chuck away spec pragma bindings
+ -- and ignore occurrences within it
+ Bool -- Keep-conjurable flag
+ -- False <=> OK to throw away *dead*
+ -- "conjurable" Ids; at the moment, that
+ -- *only* means constant methods, which
+ -- are top-level. A use of a "conjurable"
+ -- Id may appear out of thin air -- e.g.,
+ -- specialiser conjuring up refs to const methods.
+ Bool -- IgnoreINLINEPragma flag
+ -- False <=> OK to use INLINEPragma information
+ -- True <=> ignore INLINEPragma information
+ IdSet -- Candidates
addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
- = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
+addNewCands (OccEnv kd ks kc ip cands) ids
+ = OccEnv kd ks kc ip (cands `unionIdSets` mkIdSet ids)
addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
- = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
+addNewCand (OccEnv ks kd kc ip cands) id
+ = OccEnv kd ks kc ip (addOneToIdSet cands id)
isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
+isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfIdSet` cands
ignoreINLINEPragma :: OccEnv -> Bool
-ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
+ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
keepUnusedBinding :: OccEnv -> Id -> Bool
keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
- = keep_dead || (keep_spec && is_spec)
- where
- is_spec = maybeToBool (isSpecPragmaId_maybe binder)
+ = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
keepBecauseConjurable :: OccEnv -> Id -> Bool
keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
- = keep_conjurable && is_conjurable
- where
- is_conjurable = isConstMethodId binder
+ = keep_conjurable && isConstMethodId binder
type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
:: UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetails usage1 usage2
- = --BSCC("combineUsages")
- combineIdEnvs combineBinderInfo usage1 usage2
- --ESCC
+ = combineIdEnvs addBinderInfo usage1 usage2
combineAltsUsageDetails usage1 usage2
- = --BSCC("combineUsages")
- combineIdEnvs combineAltsBinderInfo usage1 usage2
- --ESCC
+ = combineIdEnvs orBinderInfo usage1 usage2
addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
-addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
+addOneOcc usage id info
+ = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
-- ToDo: make this more efficient
emptyDetails = (nullIdEnv :: UsageDetails)
unitDetails id info = (unitIdEnv id info :: UsageDetails)
-tagBinders :: UsageDetails -- Of scope
- -> [Id] -- Binders
- -> (UsageDetails, -- Details with binders removed
- [(Id,BinderInfo)]) -- Tagged binders
+tagBinders :: UsageDetails -- Of scope
+ -> [Id] -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ [(Id,BinderInfo)]) -- Tagged binders
tagBinders usage binders
= (usage `delManyFromIdEnv` binders,
- [(binder, usage_of usage binder) | binder <- binders]
+ [ (binder, usage_of usage binder) | binder <- binders ]
)
-tagBinder :: UsageDetails -- Of scope
- -> Id -- Binders
- -> (UsageDetails, -- Details with binders removed
- (Id,BinderInfo)) -- Tagged binders
+tagBinder :: UsageDetails -- Of scope
+ -> Id -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ (Id,BinderInfo)) -- Tagged binders
tagBinder usage binder
= (usage `delOneFromIdEnv` binder,
usage_of usage binder
| isExported binder = ManyOcc 0 -- Exported things count as many
| otherwise
- = case lookupIdEnv usage binder of
+ = case (lookupIdEnv usage binder) of
Nothing -> DeadCode
Just info -> info
isNeeded env usage binder
- = case usage_of usage binder of
+ = case (usage_of usage binder) of
DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
other -> True
\end{code}
\begin{code}
occurAnalyseBinds
- :: [PlainCoreBinding] -- input
- -> (GlobalSwitch -> Bool)
+ :: [CoreBinding] -- input
-> (SimplifierSwitch -> Bool)
-> [SimplifiableCoreBinding] -- output
-occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
- | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
- | otherwise = binds'
+occurAnalyseBinds binds simplifier_sw_chkr
+ | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
+ (ppAboves (map (ppr PprDebug) binds'))
+ binds'
+ | otherwise = binds'
where
(_, binds') = do initial_env binds
(simplifier_sw_chkr KeepSpecPragmaIds)
(not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
(simplifier_sw_chkr IgnoreINLINEPragma)
- emptyUniqSet
+ emptyIdSet
do env [] = (emptyDetails, [])
do env (bind:binds)
where
new_env = env `addNewCands` (bindersOf bind)
(binds_usage, the_rest) = do new_env binds
- (final_usage, new_binds) = --BSCC("occAnalBind1")
- occAnalBind env bind binds_usage
- --ESCC
+ (final_usage, new_binds) = occAnalBind env bind binds_usage
\end{code}
\begin{code}
-occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars
- -> PlainCoreExpr
- -> (IdEnv BinderInfo, -- Occ info for interesting free vars
+occurAnalyseExpr :: IdSet -- Set of interesting free vars
+ -> CoreExpr
+ -> (IdEnv BinderInfo, -- Occ info for interesting free vars
SimplifiableCoreExpr)
occurAnalyseExpr candidates expr
False {- Do not ignore INLINE Pragma -}
candidates
-occurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
+occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
occurAnalyseGlobalExpr expr
- = -- Top level expr, so no interesting free vars, and
+ = -- Top level expr, so no interesting free vars, and
-- discard occurence info returned
- expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr
+ snd (occurAnalyseExpr emptyIdSet expr)
\end{code}
%************************************************************************
\begin{code}
occAnalBind :: OccEnv
- -> PlainCoreBinding
+ -> CoreBinding
-> UsageDetails -- Usage details of scope
-> (UsageDetails, -- Of the whole let(rec)
[SimplifiableCoreBinding])
-occAnalBind env (CoNonRec binder rhs) body_usage
+occAnalBind env (NonRec binder rhs) body_usage
| isNeeded env body_usage binder -- It's mentioned in body
= (final_body_usage `combineUsageDetails` rhs_usage,
- [CoNonRec tagged_binder rhs'])
+ [NonRec tagged_binder rhs'])
| otherwise
= (body_usage, [])
This seems to miss an obvious improvement.
@
- letrec f = ...g...
- g = ...f...
- in
+ letrec f = ...g...
+ g = ...f...
+ in
...g...
===>
\begin{code}
-occAnalBind env (CoRec pairs) body_usage
+occAnalBind env (Rec pairs) body_usage
= foldr do_final_bind (body_usage, []) sccs
where
analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
-
+
lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
lookup id = assoc "occAnalBind:lookup" analysed_pairs id
---- stuff for dependency analysis of binds -------------------------------
edges :: [(Id,Id)] -- (a,b) means a mentions b
- edges = concat [ edges_from binder rhs_usage
+ edges = concat [ edges_from binder rhs_usage
| (binder, (rhs_usage, _)) <- analysed_pairs]
edges_from :: Id -> UsageDetails -> [(Id,Id)]
sccs :: [[Id]]
sccs = case binders of
[_] -> [binders] -- Singleton; no need to analyse
- other -> stronglyConnComp eqId edges binders
+ other -> stronglyConnComp (==) edges binders
---- stuff to "re-constitute" bindings from dependency-analysis info ------
(combined_usage, tagged_binder) = tagBinder total_usage binder
new_bind
- | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
- | otherwise = CoNonRec tagged_binder rhs'
+ | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
+ | otherwise = NonRec tagged_binder rhs'
where
mentions_itself binder usage
= maybeToBool (lookupIdEnv usage binder)
total_usage = foldr combineUsageDetails body_usage rhs_usages
(combined_usage, tagged_binders) = tagBinders total_usage sCC
- new_bind = CoRec (tagged_binders `zip` rhss')
+ new_bind = Rec (zipEqual "occAnalBind" tagged_binders rhss')
\end{code}
@occAnalRhs@ deals with the question of bindings where the Id is marked
\begin{code}
occAnalRhs :: OccEnv
- -> Id -- Binder
- -> PlainCoreExpr -- Rhs
+ -> Id -- Binder
+ -> CoreExpr -- Rhs
-> (UsageDetails, SimplifiableCoreExpr)
occAnalRhs env id rhs
~~~~~~~~~~~
\begin{code}
occAnal :: OccEnv
- -> PlainCoreExpr
- -> (UsageDetails, -- Gives info only about the "interesting" Ids
+ -> CoreExpr
+ -> (UsageDetails, -- Gives info only about the "interesting" Ids
SimplifiableCoreExpr)
-occAnal env (CoVar v)
+occAnal env (Var v)
| isCandidate env v
- = (unitIdEnv v (funOccurrence 0), CoVar v)
+ = (unitIdEnv v (funOccurrence 0), Var v)
| otherwise
- = (emptyDetails, CoVar v)
+ = (emptyDetails, Var v)
-occAnal env (CoLit lit) = (emptyDetails, CoLit lit)
-occAnal env (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
-occAnal env (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
+occAnal env (Lit lit) = (emptyDetails, Lit lit)
+occAnal env (Con con args) = (occAnalArgs env args, Con con args)
+occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
-occAnal env (CoSCC cc body)
- = (mapIdEnv markInsideSCC usage, CoSCC cc body')
+occAnal env (SCC cc body)
+ = (mapIdEnv markInsideSCC usage, SCC cc body')
where
(usage, body') = occAnal env body
-occAnal env (CoApp fun arg)
- = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
+occAnal env (Coerce c ty body)
+ = (usage, Coerce c ty body')
where
- (fun_usage, fun') = occAnal env fun
- arg_usage = occAnalAtom env arg
-
-occAnal env (CoTyApp fun ty)
- = (fun_usage, CoTyApp fun' ty)
+ (usage, body') = occAnal env body
+
+occAnal env (App fun arg)
+ = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
where
- (fun_usage, fun') = occAnal env fun
+ (fun_usage, fun') = occAnal env fun
+ arg_usage = occAnalArg env arg
-occAnal env (CoLam binders body)
- = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
+occAnal env (Lam (ValBinder binder) body)
+ = (mapIdEnv markDangerousToDup final_usage,
+ Lam (ValBinder tagged_binder) body')
where
- new_env = env `addNewCands` binders
- (body_usage, body') = occAnal new_env body
- (final_usage, tagged_binders) = tagBinders body_usage binders
+ (body_usage, body') = occAnal (env `addNewCand` binder) body
+ (final_usage, tagged_binder) = tagBinder body_usage binder
-- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
-occAnal env (CoTyLam tyvar body)
- = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body')
+occAnal env (Lam (TyBinder tyvar) body)
+ = (mapIdEnv markDangerousToDup body_usage,
+ Lam (TyBinder tyvar) body')
where
(body_usage, body') = occAnal env body
-occAnal env (CoCase scrut alts)
+occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
+
+occAnal env (Case scrut alts)
= (scrut_usage `combineUsageDetails` alts_usage,
- CoCase scrut' alts')
+ Case scrut' alts')
where
(scrut_usage, scrut') = occAnal env scrut
(alts_usage, alts') = occAnalAlts env alts
-occAnal env (CoLet bind body)
- = (final_usage, foldr CoLet body' new_binds) -- mkCoLet* wants PlainCore... (sigh)
+occAnal env (Let bind body)
+ = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
where
new_env = env `addNewCands` (bindersOf bind)
(body_usage, body') = occAnal new_env body
- (final_usage, new_binds) = --BSCC("occAnalBind2")
- occAnalBind env bind body_usage
- --ESCC
+ (final_usage, new_binds) = occAnalBind env bind body_usage
\end{code}
Case alternatives
~~~~~~~~~~~~~~~~~
\begin{code}
-occAnalAlts env (CoAlgAlts alts deflt)
+occAnalAlts env (AlgAlts alts deflt)
= (foldr combineAltsUsageDetails deflt_usage alts_usage,
-- Note: combine*Alts*UsageDetails...
- CoAlgAlts alts' deflt')
+ AlgAlts alts' deflt')
where
(alts_usage, alts') = unzip (map do_alt alts)
(deflt_usage, deflt') = occAnalDeflt env deflt
(rhs_usage, rhs') = occAnal new_env rhs
(final_usage, tagged_args) = tagBinders rhs_usage args
-occAnalAlts env (CoPrimAlts alts deflt)
+occAnalAlts env (PrimAlts alts deflt)
= (foldr combineAltsUsageDetails deflt_usage alts_usage,
-- Note: combine*Alts*UsageDetails...
- CoPrimAlts alts' deflt')
+ PrimAlts alts' deflt')
where
(alts_usage, alts') = unzip (map do_alt alts)
(deflt_usage, deflt') = occAnalDeflt env deflt
where
(rhs_usage, rhs') = occAnal env rhs
-occAnalDeflt env CoNoDefault = (emptyDetails, CoNoDefault)
+occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
-occAnalDeflt env (CoBindDefault binder rhs)
- = (final_usage, CoBindDefault tagged_binder rhs')
+occAnalDeflt env (BindDefault binder rhs)
+ = (final_usage, BindDefault tagged_binder rhs')
where
new_env = env `addNewCand` binder
(rhs_usage, rhs') = occAnal new_env rhs
Atoms
~~~~~
\begin{code}
-occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
+occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
-occAnalAtoms env atoms
+occAnalArgs env atoms
= foldr do_one_atom emptyDetails atoms
where
- do_one_atom (CoLitAtom lit) usage = usage
- do_one_atom (CoVarAtom v) usage
+ do_one_atom (VarArg v) usage
| isCandidate env v = addOneOcc usage v (argOccurrence 0)
- | otherwise = usage
+ | otherwise = usage
+ do_one_atom other_arg usage = usage
-occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails
+occAnalArg :: OccEnv -> CoreArg -> UsageDetails
-occAnalAtom env (CoLitAtom lit) = emptyDetails
-occAnalAtom env (CoVarAtom v)
+occAnalArg env (VarArg v)
| isCandidate env v = unitDetails v (argOccurrence 0)
| otherwise = emptyDetails
+occAnalArg _ _ = emptyDetails
\end{code}
projects / ghc-hetmet.git / blobdiff