import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding )
-import {-# SOURCE #-} CoreSyn ( SimplifiableCoreExpr )
+import {-# SOURCE #-} CoreSyn ( CoreExpr )
-- for mkdependHS, CoreSyn.hi-boot refers to it:
import BinderInfo ( BinderInfo )
A @IdSpecEnv@ holds details of an @Id@'s specialisations.
\begin{code}
-type IdSpecEnv = SpecEnv SimplifiableCoreExpr
+type IdSpecEnv = SpecEnv CoreExpr
\end{code}
For example, if \tr{f}'s @SpecEnv@ contains the mapping:
_interface_ CoreSyn 1
_exports_
-CoreSyn SimplifiableCoreExpr ;
+CoreSyn CoreExpr ;
_declarations_
-- Needed by IdInfo
-1 type SimplifiableCoreExpr = GenCoreExpr (Id!Id, BinderInfo.BinderInfo) Id!Id BasicTypes.Unused ;
+1 type CoreExpr = GenCoreExpr Id!Id Id!Id BasicTypes.Unused ;
1 data GenCoreExpr a b c ;
= nukeScrutDiscount (size_up rhs)
`addSize`
size_up body
+ `addSizeN`
+ 1 -- For the allocation
size_up (Let (Rec pairs) body)
= nukeScrutDiscount (foldr addSize sizeZero [size_up rhs | (_,rhs) <- pairs])
`addSize`
size_up body
+ `addSizeN`
+ length pairs -- For the allocation
size_up (Case scrut alts)
= nukeScrutDiscount (size_up scrut)
is computed).
\begin{code}
-smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments
+smallEnoughToInline :: Id -- The function (for trace msg only)
+ -> [Bool] -- Evaluated-ness of value arguments
-> Bool -- Result is scrutinised
-> UnfoldingGuidance
-> Bool -- True => unfold it
-smallEnoughToInline _ _ UnfoldAlways = True
-smallEnoughToInline _ _ UnfoldNever = False
-smallEnoughToInline arg_is_evald_s result_is_scruted
+smallEnoughToInline _ _ _ UnfoldAlways = True
+smallEnoughToInline _ _ _ UnfoldNever = False
+smallEnoughToInline id arg_is_evald_s result_is_scruted
(UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount)
= if enough_args n_vals_wanted arg_is_evald_s &&
size - discount <= opt_UnfoldingUseThreshold
then
- pprTrace "small enough" (int size <+> int discount) True
+ -- pprTrace "small enough" (ppr id <+> int size <+> int discount)
+ True
else
False
where
| otherwise = 0
arg_discount no_of_constrs is_evald
- | is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount
- | otherwise = 1
+ | is_evald = no_of_constrs * opt_UnfoldingConDiscount
+ | otherwise = 0
\end{code}
We use this one to avoid exporting inlinings that we ``couldn't possibly
Just the same as smallEnoughToInline, except that it has no actual arguments.
\begin{code}
---UNUSED?
-couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
-couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) True guidance
+couldBeSmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
+couldBeSmallEnoughToInline id guidance = smallEnoughToInline id (repeat True) True guidance
-certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
-certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) False guidance
+certainlySmallEnoughToInline :: Id -> UnfoldingGuidance -> Bool
+certainlySmallEnoughToInline id guidance = smallEnoughToInline id (repeat False) False guidance
\end{code}
Predicates
\begin{code}
module PprCore (
pprCoreExpr, pprIfaceUnfolding,
- pprCoreBinding, pprCoreBindings
+ pprCoreBinding, pprCoreBindings,
+ pprGenericBindings
) where
#include "HsVersions.h"
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
+Un-annotated core dumps
+~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprCoreBinding :: CoreBinding -> SDoc
pprCoreBindings :: [CoreBinding] -> SDoc
+pprCoreBinding :: CoreBinding -> SDoc
+pprCoreExpr :: CoreExpr -> SDoc
+
+pprCoreBindings = pprTopBinds pprCoreEnv
+pprCoreBinding = pprTopBind pprCoreEnv
+pprCoreExpr = ppr_expr pprCoreEnv
+
+pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
+\end{code}
+
+Printer for unfoldings in interfaces
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+pprIfaceUnfolding :: CoreExpr -> SDoc
+pprIfaceUnfolding = ppr_expr pprIfaceEnv
+
+pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
+\end{code}
+
+Generic Core (possibly annotated binders etc)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+pprGenericBindings :: (Outputable bndr, Outputable occ) => [GenCoreBinding bndr occ flexi] -> SDoc
+pprGenericBindings = pprTopBinds pprGenericEnv
+
+pprGenericEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
+pprGenericEnv = init_ppr_env ppr (\_ -> ppr) ppr
+
+pprGenericArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
+pprGenericArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
+
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
+ ppr bind = ppr_bind pprGenericEnv bind
+
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
+ ppr expr = ppr_expr pprGenericEnv expr
+
+instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
+ ppr arg = ppr_arg pprGenericArgEnv arg
+
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
+ ppr alts = ppr_alts pprGenericEnv alts
+
+instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
+ ppr deflt = ppr_default pprGenericEnv deflt
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Instance declarations for Core printing}
+%* *
+%************************************************************************
+
+
+\begin{code}
init_ppr_env tvbndr pbdr pocc
= initPprEnv
(Just ppr) -- literals
- (Just ppr_con) -- data cons
+ (Just ppr) -- data cons
(Just ppr_prim) -- primops
(Just (\ cc -> text (showCostCentre True cc)))
(Just pbdr) (Just pocc) -- value vars
where
- ppr_con con = ppr con
-
-{- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.]
- [We can't treat them as ordinary applications because the Con doesn't have
- dictionaries in it, whereas the constructor Id does.]
-
- OLD VERSION:
- -- ppr_con is used when printing Con expressions; we add a "!"
- -- to distinguish them from ordinary applications. But not when
- -- printing for interfaces, where they are treated as ordinary applications
- ppr_con con | ifaceStyle sty = ppr sty con
- | otherwise = ppr sty con <> char '!'
--}
-
-- We add a "!" to distinguish Primitive applications from ordinary applications.
-- But not when printing for interfaces, where they are treated
-- as ordinary applications
else
ppr prim <> char '!')
---------------
-pprCoreBindings binds = vcat (map pprCoreBinding binds)
-
-pprCoreBinding (NonRec binder expr) = ppr_binding (binder, expr)
-
-pprCoreBinding (Rec binds)
- = vcat [ptext SLIT("Rec {"),
- vcat (map ppr_binding binds),
- ptext SLIT("end Rec }")]
-
-ppr_binding (binder, expr)
- = sep [pprCoreBinder LetBind binder,
- nest 2 (equals <+> pprCoreExpr expr)]
-\end{code}
-
-General expression printer
-
-\begin{code}
-pprCoreExpr :: CoreExpr -> SDoc
-pprCoreExpr = ppr_expr pprCoreEnv
-
-pprCoreEnv = init_ppr_env ppr pprCoreBinder ppr
-\end{code}
-
-Printer for unfoldings in interfaces
-
-\begin{code}
-pprIfaceUnfolding :: CoreExpr -> SDoc
-pprIfaceUnfolding = ppr_expr pprIfaceEnv
-
-pprIfaceEnv = init_ppr_env pprTyVarBndr pprIfaceBinder ppr
\end{code}
%************************************************************************
%* *
-\subsection{Instance declarations for Core printing}
+\subsection{The guts}
%* *
%************************************************************************
\begin{code}
-pprGenEnv :: (Outputable bndr, Outputable occ) => PprEnv flexi bndr occ
-pprGenEnv = init_ppr_env ppr (\_ -> ppr) ppr
-
-pprGenArgEnv :: (Outputable occ) => PprEnv flexi bndr occ
-pprGenArgEnv = init_ppr_env ppr (error "ppr_bndr") ppr
+pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreBinding bndr occ flexi) where
- ppr bind = ppr_bind pprGenEnv bind
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreExpr bndr occ flexi) where
- ppr expr = ppr_expr pprGenEnv expr
-
-instance (Outputable occ) => Outputable (GenCoreArg occ flexi) where
- ppr arg = ppr_arg pprGenArgEnv arg
+pprTopBind pe (NonRec binder expr)
+ = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseAlts bndr occ flexi) where
- ppr alts = ppr_alts pprGenEnv alts
-
-instance (Outputable bndr, Outputable occ) => Outputable (GenCoreCaseDefault bndr occ flexi) where
- ppr deflt = ppr_default pprGenEnv deflt
+pprTopBind pe (Rec binds)
+ = vcat [ptext SLIT("Rec {"),
+ vcat (map (ppr_binding_pe pe) binds),
+ ptext SLIT("end Rec }"),
+ text ""]
\end{code}
-%************************************************************************
-%* *
-\subsection{Workhorse routines (...????...)}
-%* *
-%************************************************************************
-
\begin{code}
ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
ppr_bind pe (Rec binds) = vcat (map pp binds)
-- If the thing isn't a redex, there's no danger of duplicating work,
-- so we can inline if it occurs once, or is small
okToInline True small_enough occ_info
- = small_enough || one_occ
+ = one_occ || small_enough
where
one_occ = case occ_info of
OneOcc _ _ _ n_alts _ -> n_alts <= 1
import CoreSyn
import Digraph ( stronglyConnCompR, SCC(..) )
import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
+ omitIfaceSigForId,
idType, idUnique, Id,
emptyIdSet, unionIdSets, mkIdSet,
elementOfIdSet,
addOneToIdSet, IdSet,
- nullIdEnv, unitIdEnv, combineIdEnvs,
+
+ IdEnv, nullIdEnv, unitIdEnv, combineIdEnvs,
delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
- mapIdEnv, lookupIdEnv, IdEnv
+ mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv
)
import Specialise ( idSpecVars )
import Name ( isExported, isLocallyDefined )
%************************************************************************
%* *
-\subsection[OccurAnal-types]{Data types}
-%* *
-%************************************************************************
-
-\begin{code}
-data OccEnv =
- OccEnv
- Bool -- IgnoreINLINEPragma flag
- -- False <=> OK to use INLINEPragma information
- -- True <=> ignore INLINEPragma information
-
- (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
- -- given the set of in-scope variables
-
- IdSet -- In-scope Ids
-
-
-addNewCands :: OccEnv -> [Id] -> OccEnv
-addNewCands (OccEnv ip ifun cands) ids
- = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids)
-
-addNewCand :: OccEnv -> Id -> OccEnv
-addNewCand (OccEnv ip ifun cands) id
- = OccEnv ip ifun (addOneToIdSet cands id)
-
-isCandidate :: OccEnv -> Id -> Bool
-isCandidate (OccEnv _ ifun cands) id = ifun id cands
-
-inlineMe :: OccEnv -> Id -> Bool
-inlineMe env id
- = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
- not ignore_inline_prag &&
- -}
- idWantsToBeINLINEd id
-
-
-type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
-
-combineUsageDetails, combineAltsUsageDetails
- :: UsageDetails -> UsageDetails -> UsageDetails
-
-combineUsageDetails usage1 usage2
- = combineIdEnvs addBinderInfo usage1 usage2
-
-combineAltsUsageDetails usage1 usage2
- = combineIdEnvs orBinderInfo usage1 usage2
-
-addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
-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 usage binders =
- let
- usage' = usage `delManyFromIdEnv` binders
- uss = [ (binder, usage_of usage binder) | binder <- binders ]
- in
- if isNullIdEnv usage' then
- (usage', uss)
- else
- (usage', uss)
-{-
- = (usage `delManyFromIdEnv` binders,
- [ (binder, usage_of usage binder) | binder <- binders ]
- )
--}
-tagBinder :: UsageDetails -- Of scope
- -> Id -- Binders
- -> (UsageDetails, -- Details with binders removed
- (Id,BinderInfo)) -- Tagged binders
-
-tagBinder usage binder =
- let
- usage' = usage `delOneFromIdEnv` binder
- us = usage_of usage binder
- cont =
- if isNullIdEnv usage' then -- Bogus test to force evaluation.
- (usage', (binder, us))
- else
- (usage', (binder, us))
- in
- if isDeadOcc us then -- Ditto
- cont
- else
- cont
-
-
-usage_of usage binder
- | isExported binder
- = noBinderInfo -- Visible-elsewhere things count as many
- | otherwise
- = case (lookupIdEnv usage binder) of
- Nothing -> deadOccurrence
- Just info -> info
-
-isNeeded env usage binder = not (isDeadOcc (usage_of usage binder))
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[OccurAnal-main]{Counting occurrences: main function}
%* *
%************************************************************************
occurAnalyseBinds binds simplifier_sw_chkr
| opt_D_dump_occur_anal = pprTrace "OccurAnal:"
- (vcat (map ppr_bind binds'))
+ (pprGenericBindings binds')
binds'
| otherwise = binds'
where
- (_, binds') = doo initial_env binds
+ (_, _, binds') = occAnalTop initial_env binds
initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
(\id in_scope -> isLocallyDefined id) -- Anything local is interesting
emptyIdSet -- Not actually used
-
- doo env [] = (emptyDetails, [])
- doo env (bind:binds)
- = (final_usage, new_binds ++ the_rest)
- where
- new_env = env `addNewCands` (bindersOf bind)
- (binds_usage, the_rest) = doo new_env binds
- (final_usage, new_binds) = occAnalBind env bind binds_usage
-
- -- This really ought to be done properly by PprCore, but
- -- it isn't. pprCoreBinding only works on Id binders, and
- -- the general case is complicated by the fact that it has to work
- -- for interface files too. Sigh
-
-ppr_bind bind@(NonRec binder expr)
- = ppr bind
-
-ppr_bind bind@(Rec binds)
- = vcat [ptext SLIT("Rec {"),
- nest 2 (ppr bind),
- ptext SLIT("end Rec }")]
\end{code}
+
\begin{code}
occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
-> CoreExpr
snd (occurAnalyseExpr (\_ -> False) expr)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Top level stuff}
+%* *
+%************************************************************************
+
+In @occAnalTop@ we do indirection-shorting. That is, if we have this:
+
+ loc = <expression>
+ ...
+ exp = loc
+
+where exp is exported, and loc is not, then we replace it with this:
+
+ loc = exp
+ exp = <expression>
+ ...
+
+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 its 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}
+occAnalTop :: OccEnv -- What's in scope
+ -> [CoreBinding]
+ -> (IdEnv BinderInfo, -- Occurrence info
+ IdEnv Id, -- Indirection elimination info
+ [SimplifiableCoreBinding]
+ )
+
+occAnalTop env [] = (emptyDetails, nullIdEnv, [])
+
+-- Special case for eliminating indirections
+occAnalTop env (NonRec exported_id (Var local_id) : binds)
+ | isExported 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 (isExported local_id) && -- Only if this one is not itself exported,
+ -- since the transformation will nuke it
+
+ not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is
+ -- something like a constructor, whose
+ -- definition is implicitly exported and
+ -- which must not vanish.
+ -- To illustrate the preceding check consider
+ -- data T = MkT Int
+ -- mkT = MkT
+ -- f x = MkT (x+1)
+ -- Here, we'll make a local, non-exported, defn for MkT, and without the
+ -- above condition we'll transform it to:
+ -- mkT = \x. MkT [x]
+ -- f = \y. mkT (y+1)
+ -- This is bad because mkT will get the IdDetails of MkT, and won't
+ -- be exported. Also the code generator won't make a definition for
+ -- the MkT constructor.
+ -- Slightly gruesome, this.
+
+
+ not (maybeToBool (lookupIdEnv ind_env local_id))
+ -- Only if not already substituted for
+
+ = -- Aha! An indirection; let's eliminate it!
+ (scope_usage, ind_env', binds')
+ where
+ (scope_usage, ind_env, binds') = occAnalTop env binds
+ ind_env' = addOneToIdEnv ind_env local_id exported_id
+
+-- The normal case
+occAnalTop env (bind : binds)
+ = (final_usage, ind_env, new_binds ++ binds')
+ where
+ new_env = env `addNewCands` (bindersOf bind)
+ (scope_usage, ind_env, binds') = occAnalTop new_env binds
+ (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage
+
+ -- Deal with any indirections
+ zap_bind (NonRec bndr rhs)
+ | bndr `elemIdEnv` ind_env = Rec (zap (bndr,rhs))
+ -- The Rec isn't strictly necessary, but it's convenient
+ zap_bind (Rec pairs)
+ | or [id `elemIdEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
+
+ zap_bind bind = bind
+
+ zap pair@(bndr,rhs) = case lookupIdEnv ind_env bndr of
+ Nothing -> [pair]
+ Just exported_id -> [(bndr, Var exported_id),
+ (exported_id, rhs)]
+\end{code}
+
+
%************************************************************************
%* *
\subsection[OccurAnal-main]{Counting occurrences: main function}
where
(rhs_usage, rhs') = occAnal env rhs
total_usage = foldr add rhs_usage (idSpecVars id)
- add v u = addOneOcc u v (argOccurrence 0)
+ add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info
+ -- (i.e manyOcc) because many copies
+ -- of the specialised thing can appear
\end{code}
Expressions
| otherwise = emptyDetails
occAnalArg _ _ = emptyDetails
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[OccurAnal-types]{Data types}
+%* *
+%************************************************************************
+
+\begin{code}
+data OccEnv =
+ OccEnv
+ Bool -- IgnoreINLINEPragma flag
+ -- False <=> OK to use INLINEPragma information
+ -- True <=> ignore INLINEPragma information
+
+ (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
+ -- given the set of in-scope variables
+
+ IdSet -- In-scope Ids
+
+
+addNewCands :: OccEnv -> [Id] -> OccEnv
+addNewCands (OccEnv ip ifun cands) ids
+ = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids)
+
+addNewCand :: OccEnv -> Id -> OccEnv
+addNewCand (OccEnv ip ifun cands) id
+ = OccEnv ip ifun (addOneToIdSet cands id)
+
+isCandidate :: OccEnv -> Id -> Bool
+isCandidate (OccEnv _ ifun cands) id = ifun id cands
+
+inlineMe :: OccEnv -> Id -> Bool
+inlineMe env id
+ = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
+ not ignore_inline_prag &&
+ -}
+ idWantsToBeINLINEd id
+
+
+type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
+
+combineUsageDetails, combineAltsUsageDetails
+ :: UsageDetails -> UsageDetails -> UsageDetails
+
+combineUsageDetails usage1 usage2
+ = combineIdEnvs addBinderInfo usage1 usage2
+
+combineAltsUsageDetails usage1 usage2
+ = combineIdEnvs orBinderInfo usage1 usage2
+
+addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
+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 usage binders =
+ let
+ usage' = usage `delManyFromIdEnv` binders
+ uss = [ (binder, usage_of usage binder) | binder <- binders ]
+ in
+ if isNullIdEnv usage' then
+ (usage', uss)
+ else
+ (usage', uss)
+{-
+ = (usage `delManyFromIdEnv` binders,
+ [ (binder, usage_of usage binder) | binder <- binders ]
+ )
+-}
+tagBinder :: UsageDetails -- Of scope
+ -> Id -- Binders
+ -> (UsageDetails, -- Details with binders removed
+ (Id,BinderInfo)) -- Tagged binders
+
+tagBinder usage binder =
+ let
+ usage' = usage `delOneFromIdEnv` binder
+ us = usage_of usage binder
+ cont =
+ if isNullIdEnv usage' then -- Bogus test to force evaluation.
+ (usage', (binder, us))
+ else
+ (usage', (binder, us))
+ in
+ if isDeadOcc us then -- Ditto
+ cont
+ else
+ cont
+
+
+usage_of usage binder
+ | isExported binder
+ = noBinderInfo -- Visible-elsewhere things count as many
+ | otherwise
+ = case (lookupIdEnv usage binder) of
+ Nothing -> deadOccurrence
+ Just info -> info
+
+isNeeded env usage binder = not (isDeadOcc (usage_of usage binder))
+\end{code}
+
+
replacePragmaInfo, getIdDemandInfo, idType,
getIdInfo, getPragmaInfo, mkIdWithNewUniq,
nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
- lookupIdEnv, IdEnv, omitIfaceSigForId,
+ lookupIdEnv, IdEnv,
Id
)
import IdInfo ( willBeDemanded, DemandInfo )
Several tasks are done by @tidyCorePgm@
-1. Eliminate indirections. The point here is to transform
- x_local = E
- x_exported = x_local
- ==>
- x_exported = E
+----------------
+ [March 98] Indirections are now elimianted by the occurrence analyser
+ -- 1. Eliminate indirections. The point here is to transform
+ -- x_local = E
+ -- x_exported = x_local
+ -- ==>
+ -- x_exported = E
2. Make certain top-level bindings into Globals. The point is that
Global things get externally-visible labels at code generation
generator makes global labels from the uniques for local thunks etc.]
-Eliminate indirections
-~~~~~~~~~~~~~~~~~~~~~~
-In @elimIndirections@, we look for things at the top-level of the form...
-\begin{verbatim}
- x_local = ....
- x_exported = x_local
-\end{verbatim}
-In cases we find like this, we go {\em backwards} and replace
-\tr{x_local} with \tr{x_exported}. This save a gratuitous jump
-(from \tr{x_exported} to \tr{x_local}), and makes strictness
-information propagate better.
-
-We rely on prior eta reduction to simplify things like
-\begin{verbatim}
- x_exported = /\ tyvars -> x_local tyvars
-==>
- x_exported = x_local
-\end{verbatim}
-
-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}
-
-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.
-
-General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
-Then blast the whole program (LHSs as well as RHSs) with it.
-
\begin{code}
tidyCorePgm :: Module -> [CoreBinding] -> [CoreBinding]
tidyCorePgm mod binds_in
- = initTM mod indirection_env $
- tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds ->
+ = initTM mod nullIdEnv $
+ tidyTopBindings binds_in `thenTM` \ binds ->
returnTM (bagToList binds)
- where
- (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
-
- try_bind :: IdEnv CoreBinder -> CoreBinding -> (IdEnv CoreBinder, Maybe CoreBinding)
- try_bind env_so_far (NonRec exported_binder rhs)
- | isExported exported_binder && -- Only if this is exported
- maybeToBool maybe_rhs_id && -- and the RHS is a simple Id
-
- isLocallyDefined rhs_id && -- Only if this one is defined in this
- -- module, so that we *can* change its
- -- binding to be the exported thing!
-
- not (isExported rhs_id) && -- Only if this one is not itself exported,
- -- since the transformation will nuke it
-
- not (omitIfaceSigForId rhs_id) && -- Don't do the transformation if rhs_id is
- -- something like a constructor, whose
- -- definition is implicitly exported and
- -- which must not vanish.
- -- To illustrate the preceding check consider
- -- data T = MkT Int
- -- mkT = MkT
- -- f x = MkT (x+1)
- -- Here, we'll make a local, non-exported, defn for MkT, and without the
- -- above condition we'll transform it to:
- -- mkT = \x. MkT [x]
- -- f = \y. mkT (y+1)
- -- This is bad because mkT will get the IdDetails of MkT, and won't
- -- be exported. Also the code generator won't make a definition for
- -- the MkT constructor.
- -- Slightly gruesome, this.
-
- not (maybeToBool (lookupIdEnv env_so_far rhs_id))
- -- Only if not already substituted for
-
- = (addOneToIdEnv env_so_far rhs_id (ValBinder new_rhs_id), Nothing)
- where
- maybe_rhs_id = case etaCoreExpr rhs of
- Var rhs_id -> Just rhs_id
- other -> Nothing
- Just rhs_id = maybe_rhs_id
- new_rhs_id = exported_binder `replaceIdInfo` getIdInfo rhs_id
- `replacePragmaInfo` getPragmaInfo rhs_id
- -- NB: we keep the Pragmas and IdInfo for the old rhs_id!
- -- This is important; it might be marked "no-inline" by
- -- the occurrence analyser (because it's recursive), and
- -- we must not lose that information.
-
- try_bind env_so_far bind
- = (env_so_far, Just bind)
\end{code}
Top level bindings
\end{code}
\begin{code}
-lookForConstructor (SimplEnv _ _ _ _ _ con_apps) con args
+lookForConstructor env@(SimplEnv _ _ _ _ _ con_apps) (Con con args)
+ | switchIsSet env SimplReuseCon
= case lookupFM con_apps (UCA con val_args) of
Nothing -> Nothing
val_args = filter isValArg args -- Literals and Ids
ty_args = [ty | TyArg ty <- args] -- Just types
+lookForConstructor env other = Nothing
\end{code}
NB: In @lookForConstructor@ we used (before Apr 94) to have a special case
= SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env new_con_apps
where
new_out_id_env | okToInline (whnfOrBottom form)
- (couldBeSmallEnoughToInline guidance)
+ (couldBeSmallEnoughToInline out_id guidance)
occ_info
= out_id_env_with_unfolding
| otherwise
elemIdEnv, isNullIdEnv, addOneToIdEnv
)
import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv )
+import OccurAnal ( occurAnalyseGlobalExpr )
import Literal ( isNoRepLit )
import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun )
import SimplEnv
| maybeToBool maybe_specialisation
= tick SpecialisationDone `thenSmpl_`
simplExpr (bindTyVars env spec_bindings)
- spec_template
+ (occurAnalyseGlobalExpr spec_template)
remaining_args
result_ty
&& ok_to_inline
&& costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env)
)
- = pprTrace "Unfolding" (ppr var) $
+ = -- pprTrace "Unfolding" (ppr var) $
unfold var unf_env unf_template args result_ty
essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee
ok_to_inline = okToInline (whnfOrBottom form) small_enough occ_info
- small_enough = smallEnoughToInline arg_evals is_case_scrutinee guidance
+ small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance
arg_evals = [is_evald arg | arg <- args, isValArg arg]
is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
addIdArity, getIdArity,
getIdDemandInfo, addIdDemandInfo
)
-import Name ( isExported )
+import Name ( isExported, isLocallyDefined )
import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
atLeastArity, unknownArity )
import Literal ( isNoRepLit )
have just made things worse, perhaps a lot worse.
\begin{code}
- -- Right hand sides that are constructors
- -- let v = C args
- -- in
- --- ...(let w = C same-args in ...)...
- -- Then use v instead of w. This may save
- -- re-constructing an existing constructor.
completeNonRec env binder new_id new_rhs
- | not (isExported new_id) -- Don't bother for exported things
- -- because we won't be able to drop
- -- its binding.
- && maybeToBool maybe_atomic_rhs
- = tick tick_type `thenSmpl_`
+ = returnSmpl (env', [NonRec b r | (b,r) <- binds])
+ where
+ (env', binds) = completeBind env binder new_id new_rhs
+
+
+completeBind :: SimplEnv
+ -> InBinder -> OutId -> OutExpr -- Id and RHS
+ -> (SimplEnv, [(OutId, OutExpr)]) -- Final envt and binding(s)
+
+completeBind env binder@(_,occ_info) new_id new_rhs
+ | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
+ = (env, new_binds)
+
+ | atomic_rhs -- If rhs (after eta reduction) is atomic
+ && not (isExported new_id) -- and binder isn't exported
+ = -- Drop the binding completely
let
- env1 = notInScope env new_id
- env2 = bindIdToAtom env1 binder rhs_arg
+ env1 = notInScope env new_id
+ env2 = bindIdToAtom env1 binder the_arg
in
- returnSmpl (env2, [])
- where
- Just (rhs_arg, tick_type) = maybe_atomic_rhs
- maybe_atomic_rhs
- = -- Try first for an existing constructor application
- case maybe_con new_rhs of {
- Just con -> Just (VarArg con, ConReused);
-
- Nothing -> -- No good; try eta-reduction
- case etaCoreExpr new_rhs of {
- Var v -> Just (VarArg v, AtomicRhs);
- Lit l -> Just (LitArg l, AtomicRhs);
-
- other -> Nothing -- Neither worked, so return Nothing
- }}
-
+ (env2, [])
- maybe_con (Con con con_args) | switchIsSet env SimplReuseCon
- = lookForConstructor env con con_args
- maybe_con other_rhs = Nothing
+ | atomic_rhs -- Rhs is atomic, and new_id is exported
+ && case eta'd_rhs of { Var v -> isLocallyDefined v && not (isExported v); other -> False }
+ = -- The local variable v will be eliminated next time round
+ -- in favour of new_id, so it's a waste to replace all new_id's with v's
+ -- this time round.
+ -- This case is an optional improvement; saves a simplifier iteration
+ (env, [(new_id, eta'd_rhs)])
-completeNonRec env binder@(id,occ_info) new_id new_rhs
- = returnSmpl (new_env , [NonRec new_id new_rhs])
+ | otherwise -- Non-atomic
+ = let
+ env1 = extendEnvGivenBinding env occ_info new_id new_rhs
+ in
+ (env1, new_binds)
+
where
- new_env = extendEnvGivenBinding env occ_info new_id new_rhs
+ new_binds = [(new_id, new_rhs)]
+ atomic_rhs = is_atomic eta'd_rhs
+ eta'd_rhs = case lookForConstructor env new_rhs of
+ Just v -> Var v
+ other -> etaCoreExpr new_rhs
+
+ the_arg = case eta'd_rhs of
+ Var v -> VarArg v
+ Lit l -> LitArg l
\end{code}
----------------------------------------------------------------------------
| otherwise
= simplRhsExpr env binder rhs new_id `thenSmpl` \ (new_rhs, arity) ->
let
- new_id' = new_id `withArity` arity
-
- -- ToDo: this next bit could usefully share code with completeNonRec
-
- new_env
- | idMustNotBeINLINEd new_id -- Occurrence analyser says "don't inline"
- = env
-
- | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic
- = let
- env1 = notInScope env new_id
- in
- bindIdToAtom env1 binder the_arg
-
- | otherwise -- Non-atomic
- = extendEnvGivenBinding env occ_info new_id new_rhs
- -- Don't eta if it doesn't eliminate the binding
-
- eta'd_rhs = etaCoreExpr new_rhs
- the_arg = case eta'd_rhs of
- Var v -> VarArg v
- Lit l -> LitArg l
+ new_id' = new_id `withArity` arity
+ (new_env, new_binds') = completeBind env binder new_id' new_rhs
in
simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
- returnSmpl ((new_id', new_rhs) : new_pairs, final_env)
+ returnSmpl (new_binds' ++ new_pairs, final_env)
where
ok_to_dup = switchIsSet env SimplOkToDupCode
\end{code}
TyVarEnv, mkTyVarEnv, delFromTyVarEnv
)
import CoreSyn
-import OccurAnal ( occurAnalyseGlobalExpr )
+import PprCore () -- Instances
import Name ( NamedThing(..), getSrcLoc )
import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues )
(new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff
add (tyvars, tys, template) (spec_env, errs)
- = case addToSpecEnv True spec_env tyvars tys (occurAnalyseGlobalExpr template) of
+ = case addToSpecEnv True spec_env tyvars tys template of
Succeeded spec_env' -> (spec_env', errs)
Failed err -> (spec_env, err:errs)
where
te' = delFromTyVarEnv te tyvar
- go te ve (Lam b@(ValBinder (v,_)) e) = Lam b (go te ve' e)
+ go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
where
ve' = delOneFromIdEnv ve v
-- if two, then a worker and a
-- wrapper.
tryWW fn_id rhs
- | (certainlySmallEnoughToInline $
+ | (certainlySmallEnoughToInline fn_id $
calcUnfoldingGuidance (getInlinePragma fn_id)
opt_UnfoldingCreationThreshold
rhs
sig_id | any inline_please id_infos = addInlinePragma imp_id
| otherwise = imp_id
- inline_please (HsUnfold inline _) = inline
- inline_please other = False
+ inline_please (HsUnfold inline _) = inline
+ inline_please (HsStrictness (HsStrictnessInfo _ (Just _))) = True -- Inline wrappers
+ inline_please other = False
in
returnTc sig_id
)) `thenTc` \ sig_id ->
projects / ghc-hetmet.git / commitdiff