Commit b70e2f94 authored by simonpj's avatar simonpj
Browse files

[project @ 1999-01-28 09:19:57 by simonpj]

Always inline nullary constructors.  This makes a 
difference in:

	case x ># y of r {
	  True  -> f1 r
	  False -> f2 r
 	}

The code generator currently has difficulty binding "r"
to the boolean result of the comparision (and the compiler
crashes).  This fix substitutes for r, thus:

	case x ># y of r {
	  True  -> f1 True
	  False -> f2 False
 	}

Voila.
parent c015aa50
......@@ -11,7 +11,6 @@ module IdInfo (
IdInfo, -- Abstract
noIdInfo,
ppIdInfo,
-- Arity
ArityInfo(..),
......@@ -110,24 +109,6 @@ noIdInfo = IdInfo {
}
\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@}
......@@ -280,7 +261,6 @@ might have a specialisation
where pi' :: Lift Int# is the specialised version of pi.
%************************************************************************
%* *
\subsection[strictness-IdInfo]{Strictness info about an @Id@}
......
......@@ -130,26 +130,6 @@ mkWiredInTyConName uniq mod fs tycon
= 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)
......
......@@ -19,7 +19,7 @@ module CoreUnfold (
noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
isEvaldUnfolding, hasUnfolding,
smallEnoughToInline, couldBeSmallEnoughToInline,
smallEnoughToInline, unfoldAlways, couldBeSmallEnoughToInline,
certainlySmallEnoughToInline,
okToUnfoldInHiFile,
......@@ -132,6 +132,10 @@ data UnfoldingGuidance
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}
......
......@@ -619,7 +619,7 @@ substId clone_fn
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
......
......@@ -19,10 +19,15 @@ import CoreSyn
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}
......@@ -96,9 +101,8 @@ initCoreEnv pbdr
(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}
%************************************************************************
......@@ -315,3 +319,39 @@ pprTypedBinder binder
-- 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}
......@@ -347,8 +347,10 @@ ifaceId get_idinfo needed_ids is_rec id rhs
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
......@@ -360,8 +362,9 @@ ifaceId get_idinfo needed_ids is_rec id rhs
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}
......
......@@ -71,7 +71,8 @@ newImportedGlobalName mod occ
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_`
......
......@@ -251,7 +251,7 @@ occAnalBind :: OccEnv
[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
......@@ -341,7 +341,7 @@ occAnalBind env (Rec pairs) body_usage
-- 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)
......@@ -352,7 +352,7 @@ occAnalBind env (Rec pairs) body_usage
-- 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)
......@@ -735,6 +735,11 @@ emptyDetails = (emptyVarEnv :: UsageDetails)
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
......
......@@ -42,7 +42,7 @@ import Name ( isExported, isLocallyDefined )
import CoreSyn
import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
mkUnfolding, smallEnoughToInline,
isEvaldUnfolding
isEvaldUnfolding, unfoldAlways
)
import CoreUtils ( IdSubst, SubstCoreExpr(..),
cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
......@@ -774,7 +774,8 @@ simplPrags old_bndr new_bndr new_rhs
= 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
......@@ -893,28 +894,6 @@ okToInline :: SwitchChecker
-- 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
......@@ -927,27 +906,35 @@ okToInline sw_chkr in_scope id form guidance cont
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
......@@ -992,8 +979,7 @@ contIsInteresting (ArgOf _ _ _) = False
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
......@@ -1033,6 +1019,7 @@ applies when x is bound to a lambda expression. Hence
contIsInteresting looks for case expressions with just a single
default case.
%************************************************************************
%* *
\subsection{The main rebuilder}
......@@ -1455,19 +1442,20 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment