import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial,
+import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
findDefault, exprOkForSpeculation, exprIsHNF
)
-import Id ( idType, isDataConWorkId, idOccInfo, isDictId, idArity,
+import Literal ( mkStringLit )
+import CoreUnfold ( smallEnoughToInline )
+import MkId ( eRROR_ID )
+import Id ( idType, isDataConWorkId, idOccInfo, isDictId,
mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
idUnfolding, idNewStrictness, idInlinePragma,
)
)
import Name ( mkSysTvName )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
-import DataCon ( dataConRepArity, dataConTyVars, dataConArgTys, isVanillaDataCon )
+import DataCon ( dataConRepArity, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
import Var ( tyVarKind, mkTyVar )
import VarSet
-import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
Activation, isAlwaysActive, isActive )
import Util ( lengthExceeds )
import Outputable
prag = idInlinePragma bndr
try_once in_lam int_cxt -- There's one textual occurrence
- = not in_lam && (isNotTopLevel top_lvl || early_phase)
- || (canInlineInLam rhs && int_cxt)
- --
+ | not in_lam = isNotTopLevel top_lvl || early_phase
+ | otherwise = int_cxt && canInlineInLam rhs
+
+-- Be very careful before inlining inside a lambda, becuase (a) we must not
+-- invalidate occurrence information, and (b) we want to avoid pushing a
+-- single allocation (here) into multiple allocations (inside lambda).
+-- Inlining a *function* with a single *saturated* call would be ok, mind you.
+-- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
+-- where
+-- is_cheap = exprIsCheap rhs
+-- ok = is_cheap && int_cxt
+
-- int_cxt The context isn't totally boring
-- E.g. let f = \ab.BIG in \y. map f xs
-- Don't want to substitute for f, because then we allocate
-- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
-- so substituting rhs inside a lambda doesn't change the occ info.
-- Sadly, not quite the same as exprIsHNF.
- canInlineInLam (Var x) = occ_info_ok (idOccInfo x)
canInlineInLam (Lit l) = True
- canInlineInLam (Type ty) = True
canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e
- canInlineInLam (App e (Type _)) = canInlineInLam e
canInlineInLam (Note _ e) = canInlineInLam e
canInlineInLam _ = False
- occ_info_ok (OneOcc in_lam _ _) = in_lam
- occ_info_ok NoOccInfo = True
- occ_info_ok _ = False
-
early_phase = case phase of
SimplPhase 0 -> False
other -> True
story for now.
\begin{code}
-postInlineUnconditionally :: SimplEnv -> OutId -> OccInfo -> OutExpr -> Bool
-postInlineUnconditionally env bndr occ_info rhs
+postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -> OccInfo -> OutExpr -> Unfolding -> Bool
+postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
| not active = False
| isLoopBreaker occ_info = False
| isExportedId bndr = False
| exprIsTrivial rhs = True
- | otherwise = False
+ | otherwise
+ = case occ_info of
+ OneOcc in_lam one_br int_cxt
+ -> (one_br || smallEnoughToInline unfolding) -- Small enough to dup
+ -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
+ --
+ -- NB: Do we want to inline arbitrarily big things becuase
+ -- one_br is True? that can lead to inline cascades. But
+ -- preInlineUnconditionlly has dealt with all the common cases
+ -- so perhaps it's worth the risk. Here's an example
+ -- let f = if b then Left (\x.BIG) else Right (\y.BIG)
+ -- in \y. ....f....
+ -- We can't preInlineUnconditionally because that woud invalidate
+ -- the occ info for b. Yet f is used just once, and duplicating
+ -- the case work is fine (exprIsCheap).
+
+ && ((isNotTopLevel top_lvl && not in_lam) ||
+ -- But outside a lambda, we want to be reasonably aggressive
+ -- about inlining into multiple branches of case
+ -- e.g. let x = <non-value>
+ -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
+ -- Inlining can be a big win if C3 is the hot-spot, even if
+ -- the uses in C1, C2 are not 'interesting'
+ -- An example that gets worse if you add int_cxt here is 'clausify'
+
+ (isCheapUnfolding unfolding && int_cxt))
+ -- isCheap => acceptable work duplication; in_lam may be true
+ -- int_cxt to prevent us inlining inside a lambda without some
+ -- good reason. See the notes on int_cxt in preInlineUnconditionally
+
+ other -> False
+ -- The point here is that for *non-values* that occur
+ -- outside a lambda, the call-site inliner won't have
+ -- a chance (becuase it doesn't know that the thing
+ -- only occurs once). The pre-inliner won't have gotten
+ -- it either, if the thing occurs in more than one branch
+ -- So the main target is things like
+ -- let x = f y in
+ -- case v of
+ -- True -> case x of ...
+ -- False -> case x of ...
+ -- I'm not sure how important this is in practice
where
active = case getMode env of
SimplGently -> isAlwaysActive prag
\begin{code}
prepareAlts :: OutExpr -- Scrutinee
- -> InId -- Case binder
+ -> InId -- Case binder (passed only to use in statistics)
-> [InAlt] -- Increasing order
-> SimplM ([InAlt], -- Better alternatives, still incresaing order
[AltCon]) -- These cases are handled
-- Filter out the default, if it can't happen,
-- or replace it with "proper" alternative if there
-- is only one constructor left
- prepareDefault case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
+ prepareDefault scrut case_bndr handled_cons maybe_deflt `thenSmpl` \ deflt_alt ->
returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
-- We need the mergeAlts in case the new default_alt
-- has turned into a constructor alternative.
-prepareDefault case_bndr handled_cons (Just rhs)
- | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
+prepareDefault scrut case_bndr handled_cons (Just rhs)
+ | Just (tycon, inst_tys) <- splitTyConApp_maybe (exprType scrut),
+ -- Use exprType scrut here, rather than idType case_bndr, because
+ -- case_bndr is an InId, so exprType scrut may have more information
+ -- Test simpl013 is an example
isAlgTyCon tycon, -- It's a data type, tuple, or unboxed tuples.
not (isNewTyCon tycon), -- We can have a newtype, if we are just doing an eval:
-- case x of { DEFAULT -> e }
| otherwise
= returnSmpl [(DEFAULT, [], rhs)]
-prepareDefault case_bndr handled_cons Nothing
+prepareDefault scrut case_bndr handled_cons Nothing
= returnSmpl []
mk_args missing_con inst_tys
= mk_tv_bndrs missing_con inst_tys `thenSmpl` \ (tv_bndrs, inst_tys') ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
- let arg_tys = dataConArgTys missing_con inst_tys'
+ let arg_tys = dataConInstArgTys missing_con inst_tys'
arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys
in
returnSmpl (tv_bndrs ++ arg_ids)
-- 0. Check for empty alternatives
--------------------------------------------------
-#ifdef DEBUG
+-- This isn't strictly an error. It's possible that the simplifer might "see"
+-- that an inner case has no accessible alternatives before it "sees" that the
+-- entire branch of an outer case is inaccessible. So we simply
+-- put an error case here insteadd
mkCase1 scrut case_bndr ty []
= pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
- returnSmpl scrut
-#endif
+ return (mkApps (Var eRROR_ID)
+ [Type ty, Lit (mkStringLit "Impossible alternative")])
--------------------------------------------------
-- 1. Eliminate the case altogether if poss
projects / ghc-hetmet.git / blobdiff