IdInfo, -- Abstract
noIdInfo,
- ppIdInfo,
-- Arity
ArityInfo(..),
}
\end{code}
-\begin{code}
-ppIdInfo :: IdInfo -> SDoc
-ppIdInfo (IdInfo {arityInfo = a,
- demandInfo = d,
- strictnessInfo = s,
- updateInfo = u,
- cafInfo = c
- })
- = hsep [
- ppArityInfo a,
- ppUpdateInfo u,
- ppStrictnessInfo s,
- ppr d,
- ppCafInfo c
- -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
- ]
-\end{code}
-
%************************************************************************
%* *
\subsection[arity-IdInfo]{Arity info about an @Id@}
where pi' :: Lift Int# is the specialised version of pi.
-
%************************************************************************
%* *
\subsection[strictness-IdInfo]{Strictness info about an @Id@}
= Name { n_uniq = uniq, n_sort = WiredInTyCon mod tycon,
n_occ = mkSrcOccFS tcName fs, n_prov = SystemProv }
-fixupSystemName :: Name -> Module -> Provenance -> Name
- -- Give the SystemProv name an appropriate provenance, and
- -- perhaps change the Moulde too (so that its HiFlag is right)
- -- There is a painful hack in that we want to push this
- -- better name into an WiredInId/TyCon so that it prints
- -- nicely in error messages
-fixupSystemName name@(Name {n_sort = Global _}) mod' prov'
- = name {n_sort = Global mod', n_prov = prov'}
-
-fixupSystemName name@(Name {n_sort = WiredInId _ id}) mod' prov'
- = name'
- where
- name' = name {n_sort = WiredInId mod' id', n_prov = prov'}
- id' = setIdName id name'
-
-fixupSystemName name@(Name {n_sort = WiredInTyCon _ tc}) mod' prov'
- = name'
- where
- name' = name {n_sort = WiredInTyCon mod' tc', n_prov = prov'}
- tc' = setTyConName tc name'
---------------------------------------------------------------------
mkDerivedName :: (OccName -> OccName)
noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
isEvaldUnfolding, hasUnfolding,
- smallEnoughToInline, couldBeSmallEnoughToInline,
+ smallEnoughToInline, unfoldAlways, couldBeSmallEnoughToInline,
certainlySmallEnoughToInline,
okToUnfoldInHiFile,
Int -- Scrutinee discount: the discount to substract if the thing is in
-- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
+
+unfoldAlways :: UnfoldingGuidance -> Bool
+unfoldAlways UnfoldAlways = True
+unfoldAlways other = False
\end{code}
\begin{code}
ty' = fullSubstTy ty_subst in_scope id_ty
-- id2 has its SpecEnv zapped
- -- It's filled in later by
+ -- It's filled in later by Simplify.simplPrags
(id2,old2) | isEmptySpecEnv spec_env = (id1, True)
| otherwise = (setIdSpecialisation id1 emptySpecEnv, False)
spec_env = getIdSpecialisation id
import CostCentre ( pprCostCentreCore )
import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
import Var ( isTyVar )
-import IdInfo ( ppIdInfo )
+import IdInfo ( IdInfo,
+ arityInfo, ppArityInfo,
+ demandInfo, updateInfo, ppUpdateInfo, specInfo,
+ strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo
+ )
import Const ( Con(..), DataCon )
import DataCon ( isTupleCon, isUnboxedTupleCon )
import PprType ( pprParendType, pprTyVarBndr )
+import SpecEnv ( specEnvToList )
import PprEnv
import Outputable
\end{code}
(Just ppr) -- tyvar occs
(Just pprParendType) -- types
- (Just pbdr) (Just pprIdBndr) -- value vars
- -- The pprIdBndr part here is a temporary debugging aid
- -- Revert to ppr if it gets tiresome
+ (Just pbdr) (Just ppr) -- value vars
+ -- Use pprIdBndr for this last one as a debugging device.
\end{code}
%************************************************************************
-- When printing any Id binder in debug mode, we print its inline pragma
pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id))
\end{code}
+
+
+\begin{code}
+ppIdInfo :: IdInfo -> SDoc
+ppIdInfo info
+ = hsep [
+ ppArityInfo a,
+ ppUpdateInfo u,
+ ppStrictnessInfo s,
+ ppr d,
+ ppCafInfo c,
+ ppSpecInfo p
+ -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
+ ]
+ where
+ a = arityInfo info
+ d = demandInfo info
+ s = strictnessInfo info
+ u = updateInfo info
+ c = cafInfo info
+ p = specInfo info
+\end{code}
+
+\begin{code}
+ppSpecInfo spec_env
+ = vcat (map pp_item (specEnvToList spec_env))
+ where
+ pp_item (tyvars, tys, rhs) = hsep [ptext SLIT("__P"),
+ hsep (map pprParendType tys),
+ ptext SLIT("->"),
+ ppr head]
+ where
+ (_, body) = collectBinders rhs
+ (head, _) = collectArgs body
+\end{code}
+
unfold_ids `unionVarSet`
spec_ids
- worker_ids | has_worker = unitVarSet work_id
- | otherwise = emptyVarSet
+ worker_ids | has_worker && interesting work_id = unitVarSet work_id
+ -- Conceivably, the worker might come from
+ -- another module
+ | otherwise = emptyVarSet
spec_ids = foldr add emptyVarSet spec_list
where
find_fvs expr = free_vars
where
free_vars = exprSomeFreeVars interesting expr
- interesting id = isId id && isLocallyDefined id &&
- not (omitIfaceSigForId id)
+
+ interesting id = isId id && isLocallyDefined id &&
+ not (omitIfaceSigForId id)
\end{code}
\begin{code}
Just name | isSystemName name -- A known-key name; fix the provenance and module
-> getOmitQualFn `thenRn` \ omit_fn ->
let
- new_name = fixupSystemName name mod (NonLocalDef ImplicitImport (omit_fn name))
+ new_name = setNameProvenance (setNameModule name mod)
+ (NonLocalDef ImplicitImport (omit_fn name))
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us, inst_ns, new_cache) `thenRn_`
[CoreBind])
occAnalBind env (NonRec binder rhs) body_usage
- | isDeadBinder tagged_binder -- It's not mentioned
+ | not (binder `usedIn` body_usage) -- It's not mentioned
= (body_usage, [])
| otherwise -- It's mentioned in the body
-- Non-recursive SCC
do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
- | isDeadBinder tagged_bndr
+ | not (bndr `usedIn` body_usage)
= (body_usage, binds_so_far) -- Dead code
| otherwise
= (combined_usage, new_bind : binds_so_far)
-- Recursive SCC
do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
- | all isDeadBinder tagged_bndrs
+ | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
= (body_usage, binds_so_far) -- Dead code
| otherwise
= (combined_usage, final_bind:binds_so_far)
unitDetails id info = (unitVarEnv id info :: UsageDetails)
+usedIn :: Id -> UsageDetails -> Bool
+v `usedIn` details = isExported v
+ || v `elemVarEnv` details
+ || isSpecPragmaId v
+
tagBinders :: UsageDetails -- Of scope
-> [Id] -- Binders
-> (UsageDetails, -- Details with binders removed
import CoreSyn
import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
mkUnfolding, smallEnoughToInline,
- isEvaldUnfolding
+ isEvaldUnfolding, unfoldAlways
)
import CoreUtils ( IdSubst, SubstCoreExpr(..),
cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
= returnSmpl (bndr_w_unfolding)
| otherwise
- = getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
+ = pprTrace "simplPrags" (ppr old_bndr) $
+ getSimplBinderStuff `thenSmpl` \ (ty_subst, id_subst, in_scope, us) ->
let
spec_env' = substSpecEnv ty_subst in_scope (subst_val id_subst) spec_env
in
-- so we can inline if it occurs once, or is small
okToInline sw_chkr in_scope id form guidance cont
- | switchIsOn sw_chkr EssentialUnfoldingsOnly
- =
-#ifdef DEBUG
- if opt_D_dump_inlinings then
- pprTrace "Considering inlining"
- (ppr id <+> vcat [text "essential inlinings only",
- text "inline prag:" <+> ppr inline_prag,
- text "ANSWER =" <+> if result then text "YES" else text "NO"])
- result
- else
-#endif
- result
- where
- inline_prag = getInlinePragma id
- result = idMustBeINLINEd id
- -- If "essential_unfoldings_only" is true we do no inlinings at all,
- -- EXCEPT for things that absolutely have to be done
- -- (see comments with idMustBeINLINEd)
-
-
-okToInline sw_chkr in_scope id form guidance cont
- -- Essential unfoldings only not on
=
#ifdef DEBUG
if opt_D_dump_inlinings then
text "result scrut" <+> ppr result_scrut,
text "ANSWER =" <+> if result then text "YES" else text "NO"])
result
- else
+ else
#endif
result
where
- result = case inline_prag of
- IAmDead -> pprTrace "okToInline: dead" (ppr id) False
-
- IAmASpecPragmaId -> False
- IMustNotBeINLINEd -> False
- IAmALoopBreaker -> False
- IMustBeINLINEd -> True
- IWantToBeINLINEd -> True
-
- ICanSafelyBeINLINEd inside_lam one_branch
- -> (small_enough || one_branch) && some_benefit &&
- (whnf || not_inside_lam)
-
- where
- not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
-
- other -> whnf && small_enough && some_benefit
+ result =
+ case inline_prag of
+ IAmDead -> pprTrace "okToInline: dead" (ppr id) False
+ IAmASpecPragmaId -> False
+ IMustNotBeINLINEd -> False
+ IAmALoopBreaker -> False
+ IMustBeINLINEd -> True -- If "essential_unfoldings_only" is true we do no inlinings at all,
+ -- EXCEPT for things that absolutely have to be done
+ -- (see comments with idMustBeINLINEd)
+ IWantToBeINLINEd -> inlinings_enabled
+ ICanSafelyBeINLINEd inside_lam one_branch
+ -> inlinings_enabled && (unfold_always || consider_single inside_lam one_branch)
+ NoInlinePragInfo -> inlinings_enabled && (unfold_always || consider_multi)
+
+ inlinings_enabled = not (switchIsOn sw_chkr EssentialUnfoldingsOnly)
+ unfold_always = unfoldAlways guidance
+
+ -- Consider benefit for ICanSafelyBeINLINEd
+ consider_single inside_lam one_branch
+ = (small_enough || one_branch) && some_benefit && (whnf || not_inside_lam)
+ where
+ not_inside_lam = case inside_lam of {InsideLam -> False; other -> True}
+
+ -- Consider benefit for NoInlinePragInfo
+ consider_multi = whnf && small_enough && some_benefit
-- We could consider using exprIsCheap here,
-- as in postInlineUnconditionally, but unlike the latter we wouldn't
-- necessarily eliminate a thunk; and the "form" doesn't tell
contIsInteresting (ApplyTo _ (Type _) _ cont) = contIsInteresting cont
contIsInteresting (CoerceIt _ _ _ cont) = contIsInteresting cont
--- Even a case with only a default case is a bit interesting;
--- we may be able to eliminate it after inlining.
+-- See notes below on why a case with only a DEFAULT case is not intersting
-- contIsInteresting (Select _ _ [(DEFAULT,_,_)] _ _) = False
contIsInteresting _ = True
contIsInteresting looks for case expressions with just a single
default case.
+
%************************************************************************
%* *
\subsection{The main rebuilder}
handled_cons = scrut_cons ++ [con | (con,_,_) <- alts, con /= DEFAULT]
simpl_alt (DEFAULT, _, rhs)
- = modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
+ = -- In the default case we record the constructors that the
+ -- case-binder *can't* be.
+ -- We take advantage of any OtherCon info in the case scrutinee
+ modifyInScope (case_bndr'' `setIdUnfolding` OtherCon handled_cons) $
simplExpr rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (DEFAULT, [], rhs')
simpl_alt (con, vs, rhs)
- = -- Deal with the case-bound variables
+ = -- Deal with the pattern-bound variables
-- Mark the ones that are in ! positions in the data constructor
-- as certainly-evaluated
simplBinders (add_evals con vs) $ \ vs' ->
-- Bind the case-binder to (Con args)
- -- In the default case we record the constructors it *can't* be.
- -- We take advantage of any OtherCon info in the case scrutinee
let
con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
in
projects / ghc-hetmet.git / commitdiff