#include "HsVersions.h"
-import CmdLineOpts ( intSwitchSet,
+import CmdLineOpts ( intSwitchSet, switchIsOn,
opt_SccProfilingOn, opt_PprStyle_Debug, opt_SimplDoEtaReduction,
opt_SimplNoPreInlining, opt_DictsStrict, opt_SimplPedanticBottoms,
SimplifierSwitch(..)
)
import SimplMonad
-import SimplUtils ( mkCase, transformRhs, findAlt,
+import SimplUtils ( mkCase, transformRhs, findAlt, etaCoreExpr,
simplBinder, simplBinders, simplIds, findDefault, mkCoerce
)
import Var ( TyVar, mkSysTyVar, tyVarKind, maybeModifyIdInfo )
getIdUnfolding, setIdUnfolding, isExportedId,
getIdSpecialisation, setIdSpecialisation,
getIdDemandInfo, setIdDemandInfo,
- getIdArity, setIdArity,
+ setIdInfo,
+ getIdOccInfo, setIdOccInfo,
+ zapLamIdInfo, zapFragileIdInfo,
getIdStrictness,
- setInlinePragma, getInlinePragma, idMustBeINLINEd,
- setOneShotLambda
+ setInlinePragma, mayHaveNoBinding,
+ setOneShotLambda, maybeModifyIdInfo
)
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
- specInfo, inlinePragInfo, zapLamIdInfo
+ specInfo, inlinePragInfo, setArityInfo, setInlinePragInfo, setUnfoldingInfo
)
import Demand ( Demand, isStrict, wwLazy )
import Const ( isWHNFCon, conOkForAlt )
import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons,
- callSiteInline, blackListed
+ callSiteInline, hasSomeUnfolding
)
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
coreExprType, coreAltsType, exprArity, exprIsValue,
)
import Rules ( lookupRule )
import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
-import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType,
+import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, seqType,
mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe,
funResultTy, isDictTy, isDataType, applyTy, applyTys, mkFunTys
)
-import Subst ( Subst, mkSubst, emptySubst, substExpr, substTy,
- substEnv, lookupInScope, lookupSubst, substRules
+import Subst ( Subst, mkSubst, emptySubst, substTy, substExpr,
+ substEnv, isInScope, lookupInScope, lookupIdSubst, substIdInfo
)
import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon )
import TysPrim ( realWorldStatePrimTy )
import Util ( zipWithEqual, stretchZipEqual, lengthExceeds )
import PprCore
import Outputable
+import Unique ( foldrIdKey ) -- Temp
\end{code}
-- so that if a transformation rule has unexpectedly brought
-- anything into scope, then we don't get a complaint about that.
-- It's rather as if the top-level binders were imported.
- extendInScopes top_binders $
- simpl_binds binds `thenSmpl` \ (binds', _) ->
- freeTick SimplifierDone `thenSmpl_`
+ simplIds (bindersOfBinds binds) $ \ bndrs' ->
+ simpl_binds binds bndrs' `thenSmpl` \ (binds', _) ->
+ freeTick SimplifierDone `thenSmpl_`
returnSmpl binds'
where
- top_binders = bindersOfBinds binds
- simpl_binds [] = returnSmpl ([], panic "simplTopBinds corner")
- simpl_binds (NonRec bndr rhs : binds) = simplLazyBind TopLevel bndr bndr rhs (simpl_binds binds)
- simpl_binds (Rec pairs : binds) = simplRecBind TopLevel pairs (map fst pairs) (simpl_binds binds)
+ -- We need to track the zapped top-level binders, because
+ -- they should have their fragile IdInfo zapped (notably occurrence info)
+ simpl_binds [] bs = ASSERT( null bs ) returnSmpl ([], panic "simplTopBinds corner")
+ simpl_binds (NonRec bndr rhs : binds) (b:bs) = simplLazyBind True bndr b rhs (simpl_binds binds bs)
+ simpl_binds (Rec pairs : binds) bs = simplRecBind True pairs (take n bs) (simpl_binds binds (drop n bs))
+ where
+ n = length pairs
-
-simplRecBind :: TopLevelFlag -> [(InId, InExpr)] -> [OutId]
+simplRecBind :: Bool -> [(InId, InExpr)] -> [OutId]
-> SimplM (OutStuff a) -> SimplM (OutStuff a)
simplRecBind top_lvl pairs bndrs' thing_inside
= go pairs bndrs' `thenSmpl` \ (binds', stuff) ->
simplExprC expr (Stop (substTy subst (coreExprType expr)))
-- The type in the Stop continuation is usually not used
-- It's only needed when discarding continuations after finding
- -- a function that returns bottom
+ -- a function that returns bottom.
+ -- Hence the lazy substitution
simplExprC :: CoreExpr -> SimplCont -> SimplM CoreExpr
-- Simplify an expression, given a continuation
Nothing -> rebuild (Con (PrimOp op) args2) cont2
simplExprF (Con con@(DataCon _) args) cont
- = freeTick LeafVisit `thenSmpl_`
- simplConArgs args ( \ args' ->
- rebuild (Con con args') cont)
+ = simplConArgs args $ \ args' ->
+ rebuild (Con con args') cont
simplExprF expr@(Con con@(Literal _) args) cont
= ASSERT( null args )
- freeTick LeafVisit `thenSmpl_`
rebuild expr cont
simplExprF (App fun arg) cont
-- NB: bndrs' don't have unfoldings or spec-envs
-- We add them as we go down, using simplPrags
- simplRecBind NotTopLevel pairs bndrs' (simplExprF body cont)
+ simplRecBind False pairs bndrs' (simplExprF body cont)
simplExprF expr@(Lam _ _) cont = simplLam expr cont
simplType ty `thenSmpl` \ ty' ->
rebuild (Type ty') cont
+-- Comments about the Coerce case
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- It's worth checking for a coerce in the continuation,
+-- in case we can cancel them. For example, in the initial form of a worker
+-- we may find (coerce T (coerce S (\x.e))) y
+-- and we'd like it to simplify to e[y/x] in one round of simplification
+
+simplExprF (Note (Coerce to from) e) (CoerceIt outer_to cont)
+ = simplType from `thenSmpl` \ from' ->
+ if outer_to == from' then
+ -- The coerces cancel out
+ simplExprF e cont
+ else
+ -- They don't cancel, but the inner one is redundant
+ simplExprF e (CoerceIt outer_to cont)
+
simplExprF (Note (Coerce to from) e) cont
- | to == from = simplExprF e cont
- | otherwise = getSubst `thenSmpl` \ subst ->
- simplExprF e (CoerceIt (substTy subst to) cont)
+ = simplType to `thenSmpl` \ to' ->
+ simplExprF e (CoerceIt to' cont)
-- hack: we only distinguish subsumed cost centre stacks for the purposes of
-- inlining. All other CCCSs are mapped to currentCCS.
simplLam fun cont
= go fun cont
where
- zap_it = mkLamBndrZapper fun (countArgs cont)
+ zap_it = mkLamBndrZapper fun cont
cont_ty = contResultType cont
-- Type-beta reduction
let
ty' = substTy (mkSubst in_scope arg_se) ty_arg
in
+ seqType ty' `seq`
extendSubst bndr (DoneTy ty')
(go body body_cont)
-- Exactly enough args
go expr cont = simplExprF expr cont
-
-- completeLam deals with the case where a lambda doesn't have an ApplyTo
--- continuation. Try for eta reduction, but *only* if we get all
--- the way to an exprIsTrivial expression.
--- 'acc' holds the simplified binders, in reverse order
+-- continuation.
+-- We used to try for eta reduction here, but I found that this was
+-- eta reducing things like
+-- f = \x -> (coerce (\x -> e))
+-- This made f's arity reduce, which is a bad thing, so I removed the
+-- eta reduction at this point, and now do it only when binding
+-- (at the call to postInlineUnconditionally
completeLam acc (Lam bndr body) cont
= simplBinder bndr $ \ bndr' ->
completeLam acc body cont
= simplExpr body `thenSmpl` \ body' ->
-
- case (opt_SimplDoEtaReduction, check_eta acc body') of
- (True, Just body'') -- Eta reduce!
- -> tick (EtaReduction (head acc)) `thenSmpl_`
- rebuild body'' cont
-
- other -> -- No eta reduction
- rebuild (foldl (flip Lam) body' acc) cont
- -- Remember, acc is the reversed binders
- where
- -- NB: the binders are reversed
- check_eta (b : bs) (App fun arg)
- | (varToCoreExpr b `cheapEqExpr` arg)
- = check_eta bs fun
-
- check_eta [] body
- | exprIsTrivial body && -- ONLY if the body is trivial
- not (any (`elemVarSet` body_fvs) acc)
- = Just body -- Success!
- where
- body_fvs = exprFreeVars body
-
- check_eta _ _ = Nothing -- Bale out
+ rebuild (foldl (flip Lam) body' acc) cont
+ -- Remember, acc is the *reversed* binders
mkLamBndrZapper :: CoreExpr -- Function
- -> Int -- Number of args
+ -> SimplCont -- The context
-> Id -> Id -- Use this to zap the binders
-mkLamBndrZapper fun n_args
+mkLamBndrZapper fun cont
| n_args >= n_params fun = \b -> b -- Enough args
- | otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b
+ | otherwise = \b -> zapLamIdInfo b
where
- n_params (Lam b e) | isId b = 1 + n_params e
- | otherwise = n_params e
- n_params other = 0::Int
+ -- NB: we count all the args incl type args
+ -- so we must count all the binders (incl type lambdas)
+ n_args = countArgs cont
+
+ n_params (Note _ e) = n_params e
+ n_params (Lam b e) = 1 + n_params e
+ n_params other = 0::Int
\end{code}
\begin{code}
simplConArgs :: [InArg] -> ([OutArg] -> SimplM OutExprStuff) -> SimplM OutExprStuff
-simplConArgs [] thing_inside
- = thing_inside []
-
-simplConArgs (arg:args) thing_inside
- = switchOffInlining (simplExpr arg) `thenSmpl` \ arg' ->
- -- Simplify the RHS with inlining switched off, so that
- -- only absolutely essential things will happen.
-
- simplConArgs args $ \ args' ->
-
- -- If the argument ain't trivial, then let-bind it
- if exprIsTrivial arg' then
- thing_inside (arg' : args')
- else
- newId (coreExprType arg') $ \ arg_id ->
- thing_inside (Var arg_id : args') `thenSmpl` \ res ->
- returnSmpl (addBind (NonRec arg_id arg') res)
+simplConArgs args thing_inside
+ = getSubst `thenSmpl` \ subst ->
+ go subst args thing_inside
+ where
+ go subst [] thing_inside
+ = thing_inside []
+ go subst (arg:args) thing_inside
+ | exprIsTrivial arg
+ = let
+ arg1 = substExpr subst arg
+ -- Simplify the RHS with inlining switched off, so that
+ -- only absolutely essential things will happen.
+ -- If we don't do this, consider:
+ -- let x = e in C {x}
+ -- We end up inlining x back into C's argument,
+ -- and then let-binding it again!
+ --
+ -- It's important that the substitution *does* deal with case-binder synonyms:
+ -- case x of y { True -> (x,1) }
+ -- Here we must be sure to substitute y for x when simplifying the args of the pair,
+ -- to increase the chances of being able to inline x. The substituter will do
+ -- that because the x->y mapping is held in the in-scope set.
+ in
+ ASSERT( exprIsTrivial arg1 )
+ go subst args $ \ args1 ->
+ thing_inside (arg1 : args1)
+
+ | otherwise
+ = -- If the argument ain't trivial, then let-bind it
+ simplExpr arg `thenSmpl` \ arg1 ->
+ newId (coreExprType arg1) $ \ arg_id ->
+ go subst args $ \ args1 ->
+ thing_inside (Var arg_id : args1) `thenSmpl` \ res ->
+ returnSmpl (addBind (NonRec arg_id arg1) res)
+ -- I used to use completeBeta but that was wrong, because
+ -- arg_id isn't an InId
\end{code}
simplType :: InType -> SimplM OutType
simplType ty
= getSubst `thenSmpl` \ subst ->
- returnSmpl (substTy subst ty)
+ let
+ new_ty = substTy subst ty
+ in
+ seqType new_ty `seq`
+ returnSmpl new_ty
\end{code}
#endif
simplBeta bndr rhs rhs_se cont_ty thing_inside
- | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
+ | preInlineUnconditionally False {- not black listed -} bndr
= tick (PreInlineUnconditionally bndr) `thenSmpl_`
extendSubst bndr (ContEx rhs_se rhs) thing_inside
| otherwise
- = -- Simplify the RHS
+ = -- Simplify the RHS
simplBinder bndr $ \ bndr' ->
simplArg (idType bndr') (getIdDemandInfo bndr)
rhs rhs_se cont_ty $ \ rhs' ->
returnSmpl ([], (in_scope, Case rhs' bndr' [(DEFAULT, [], mkLets floats body)]))
| otherwise
- = completeBinding bndr bndr' rhs' thing_inside
+ = completeBinding bndr bndr' False False rhs' thing_inside
\end{code}
-- Return true only for dictionary types where the dictionary
-- has more than one component (else we risk poking on the component
-- of a newtype dictionary)
- = getSubstEnv `thenSmpl` \ body_se ->
- transformRhs arg `thenSmpl` \ t_arg ->
- setSubstEnv arg_se (simplExprF t_arg (ArgOf NoDup cont_ty $ \ arg' ->
- setSubstEnv body_se (thing_inside arg')
- )) -- NB: we must restore body_se before carrying on with thing_inside!!
+ = transformRhs arg `thenSmpl` \ t_arg ->
+ getEnv `thenSmpl` \ env ->
+ setSubstEnv arg_se $
+ simplExprF t_arg (ArgOf NoDup cont_ty $ \ rhs' ->
+ setAllExceptInScope env $
+ etaFirst thing_inside rhs')
| otherwise
- = simplRhs NotTopLevel True arg_ty arg arg_se thing_inside
+ = simplRhs False {- Not top level -}
+ True {- OK to float unboxed -}
+ arg_ty arg arg_se
+ thing_inside
+
+-- Do eta-reduction on the simplified RHS, if eta reduction is on
+-- NB: etaCoreExpr only eta-reduces if that results in something trivial
+etaFirst | opt_SimplDoEtaReduction = \ thing_inside rhs -> thing_inside (etaCoreExprToTrivial rhs)
+ | otherwise = \ thing_inside rhs -> thing_inside rhs
+
+-- Try for eta reduction, but *only* if we get all
+-- the way to an exprIsTrivial expression. We don't want to remove
+-- extra lambdas unless we are going to avoid allocating this thing altogether
+etaCoreExprToTrivial rhs | exprIsTrivial rhs' = rhs'
+ | otherwise = rhs
+ where
+ rhs' = etaCoreExpr rhs
\end{code}
\begin{code}
completeBinding :: InId -- Binder
-> OutId -- New binder
+ -> Bool -- True <=> top level
+ -> Bool -- True <=> black-listed; don't inline
-> OutExpr -- Simplified RHS
-> SimplM (OutStuff a) -- Thing inside
-> SimplM (OutStuff a)
-completeBinding old_bndr new_bndr new_rhs thing_inside
- | isDeadBinder old_bndr -- This happens; for example, the case_bndr during case of
- -- known constructor: case (a,b) of x { (p,q) -> ... }
- -- Here x isn't mentioned in the RHS, so we don't want to
+completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside
+ | (case occ_info of -- This happens; for example, the case_bndr during case of
+ IAmDead -> True -- known constructor: case (a,b) of x { (p,q) -> ... }
+ other -> False) -- Here x isn't mentioned in the RHS, so we don't want to
-- create the (dead) let-binding let x = (a,b) in ...
= thing_inside
- | postInlineUnconditionally old_bndr new_rhs
+ | postInlineUnconditionally black_listed occ_info old_bndr new_rhs
-- Maybe we don't need a let-binding! Maybe we can just
-- inline it right away. Unlike the preInlineUnconditionally case
-- we are allowed to look at the RHS.
-- NB: a loop breaker never has postInlineUnconditionally True
-- and non-loop-breakers only have *forward* references
-- Hence, it's safe to discard the binding
+ --
+ -- NB: You might think that postInlineUnconditionally is an optimisation,
+ -- but if we have
+ -- let x = f Bool in (x, y)
+ -- then because of the constructor, x will not be *inlined* in the pair,
+ -- so the trivial binding will stay. But in this postInlineUnconditionally
+ -- gag we use the *substitution* to substitute (f Bool) for x, and that *will*
+ -- happen.
= tick (PostInlineUnconditionally old_bndr) `thenSmpl_`
extendSubst old_bndr (DoneEx new_rhs)
thing_inside
| otherwise
= getSubst `thenSmpl` \ subst ->
let
- bndr_info = idInfo old_bndr
- old_rules = specInfo bndr_info
- new_rules = substRules subst old_rules
-
- -- The new binding site Id needs its specialisations re-attached
- bndr_w_arity = new_bndr `setIdArity` ArityAtLeast (exprArity new_rhs)
-
- binding_site_id
- | isEmptyCoreRules old_rules = bndr_w_arity
- | otherwise = bndr_w_arity `setIdSpecialisation` new_rules
-
- -- At the occurrence sites we want to know the unfolding,
- -- and the occurrence info of the original
- -- (simplBinder cleaned up the inline prag of the original
- -- to eliminate un-stable info, in case this expression is
- -- simplified a second time; hence the need to reattach it)
- occ_site_id = binding_site_id
- `setIdUnfolding` mkUnfolding new_rhs
- `setInlinePragma` inlinePragInfo bndr_info
+ -- We make new IdInfo for the new binder by starting from the old binder,
+ -- doing appropriate substitutions.
+ -- Then we add arity and unfolding info to get the new binder
+ new_bndr_info = substIdInfo subst (idInfo old_bndr) (idInfo new_bndr)
+ `setArityInfo` ArityAtLeast (exprArity new_rhs)
+ `setUnfoldingInfo` mkUnfolding top_lvl new_rhs
+
+ final_id = new_bndr `setIdInfo` new_bndr_info
in
- modifyInScope occ_site_id thing_inside `thenSmpl` \ stuff ->
- returnSmpl (addBind (NonRec binding_site_id new_rhs) stuff)
+ -- These seqs force the Ids, and hence the IdInfos, and hence any
+ -- inner substitutions
+ final_id `seq`
+
+ (modifyInScope new_bndr final_id thing_inside `thenSmpl` \ stuff ->
+ returnSmpl (addBind (NonRec final_id new_rhs) stuff))
+
+ where
+ occ_info = getIdOccInfo old_bndr
\end{code}
* It does eta expansion
\begin{code}
-simplLazyBind :: TopLevelFlag
+simplLazyBind :: Bool -- True <=> top level
-> InId -> OutId
-> InExpr -- The RHS
-> SimplM (OutStuff a) -- The body of the binding
-- Also the binder has already been simplified, and hence is in scope
simplLazyBind top_lvl bndr bndr' rhs thing_inside
- | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
- = tick (PreInlineUnconditionally bndr) `thenSmpl_`
- getSubstEnv `thenSmpl` \ rhs_se ->
- (extendSubst bndr (ContEx rhs_se rhs) thing_inside)
+ = getBlackList `thenSmpl` \ black_list_fn ->
+ let
+ black_listed = black_list_fn bndr
+ in
- | otherwise
- = -- Simplify the RHS
- getSubstEnv `thenSmpl` \ rhs_se ->
+ if preInlineUnconditionally black_listed bndr then
+ -- Inline unconditionally
+ tick (PreInlineUnconditionally bndr) `thenSmpl_`
+ getSubstEnv `thenSmpl` \ rhs_se ->
+ (extendSubst bndr (ContEx rhs_se rhs) thing_inside)
+ else
+ -- Simplify the RHS
+ getSubstEnv `thenSmpl` \ rhs_se ->
simplRhs top_lvl False {- Not ok to float unboxed -}
(idType bndr')
rhs rhs_se $ \ rhs' ->
-- Now compete the binding and simplify the body
- completeBinding bndr bndr' rhs' thing_inside
+ completeBinding bndr bndr' top_lvl black_listed rhs' thing_inside
\end{code}
\begin{code}
-simplRhs :: TopLevelFlag
+simplRhs :: Bool -- True <=> Top level
-> Bool -- True <=> OK to float unboxed (speculative) bindings
-> OutType -> InExpr -> SubstEnv
-> (OutExpr -> SimplM (OutStuff a))
(floats_out, rhs'') | float_ubx = (floats, rhs')
| otherwise = splitFloats floats rhs'
in
- if (isTopLevel top_lvl || exprIsCheap rhs') && -- Float lets if (a) we're at the top level
- not (null floats_out) -- or (b) it exposes a cheap (i.e. duplicatable) expression
+ if (top_lvl || exprIsCheap rhs') && -- Float lets if (a) we're at the top level
+ not (null floats_out) -- or (b) it exposes a cheap (i.e. duplicatable) expression
then
tickLetFloat floats_out `thenSmpl_`
-- Do the float
-- and so there can't be any 'will be demanded' bindings in the floats.
-- Hence the assert
WARN( any demanded_float floats_out, ppr floats_out )
- setInScope in_scope' (thing_inside rhs'') `thenSmpl` \ stuff ->
+ setInScope in_scope' (etaFirst thing_inside rhs'') `thenSmpl` \ stuff ->
-- in_scope' may be excessive, but that's OK;
-- it's a superset of what's in scope
returnSmpl (addBinds floats_out stuff)
else
-- Don't do the float
- thing_inside (mkLets floats rhs')
+ etaFirst thing_inside (mkLets floats rhs')
-- In a let-from-let float, we just tick once, arbitrarily
-- choosing the first floated binder to identify it
\begin{code}
simplVar var cont
- = freeTick LeafVisit `thenSmpl_`
- getSubst `thenSmpl` \ subst ->
- case lookupSubst subst var of
- Just (DoneEx (Var v)) -> zapSubstEnv (simplVar v cont)
- Just (DoneEx e) -> zapSubstEnv (simplExprF e cont)
- Just (ContEx env' e) -> setSubstEnv env' (simplExprF e cont)
-
- Nothing -> let
- var' = case lookupInScope subst var of
- Just v' -> v'
- Nothing ->
-#ifdef DEBUG
- if isLocallyDefined var && not (idMustBeINLINEd var)
- -- The idMustBeINLINEd test accouunts for the fact
- -- that class dictionary constructors don't have top level
- -- bindings and hence aren't in scope.
- then
- -- Not in scope
- pprTrace "simplVar:" (ppr var) var
- else
-#endif
- var
- in
- getBlackList `thenSmpl` \ black_list ->
- getInScope `thenSmpl` \ in_scope ->
- completeCall black_list in_scope var' cont
+ = getSubst `thenSmpl` \ subst ->
+ case lookupIdSubst subst var of
+ DoneEx e -> zapSubstEnv (simplExprF e cont)
+ ContEx env1 e -> setSubstEnv env1 (simplExprF e cont)
+ DoneId var1 occ -> WARN( not (isInScope var1 subst) && isLocallyDefined var1 && not (mayHaveNoBinding var1),
+ text "simplVar:" <+> ppr var )
+ -- The mayHaveNoBinding test accouunts for the fact
+ -- that class dictionary constructors dont have top level
+ -- bindings and hence aren't in scope.
+ finish_var var1 occ
+ where
+ finish_var var occ
+ = getBlackList `thenSmpl` \ black_list ->
+ getInScope `thenSmpl` \ in_scope ->
+ completeCall black_list in_scope occ var cont
---------------------------------------------------------
-- Dealing with a call
-completeCall black_list_fn in_scope var cont
- -- Look for rules or specialisations that match
- -- Do this *before* trying inlining because some functions
- -- have specialisations *and* are strict; we don't want to
- -- inline the wrapper of the non-specialised thing... better
- -- to call the specialised thing instead.
- | maybeToBool maybe_rule_match
- = tick (RuleFired rule_name) `thenSmpl_`
- zapSubstEnv (simplExprF rule_rhs (pushArgs emptySubstEnv rule_args result_cont))
- -- See note below about zapping the substitution here
+completeCall black_list_fn in_scope occ var cont
-- Look for an unfolding. There's a binding for the
-- thing, but perhaps we want to inline it anyway
-- Then when we inline y, we must *not* replace x by x' in
-- the inlined copy!!
- | otherwise -- Neither rule nor inlining
+ | otherwise -- No inlining
-- Use prepareArgs to use function strictness
= prepareArgs (ppr var) (idType var) (get_str var) cont $ \ args' cont' ->
- rebuild (mkApps (Var var) args') cont'
+
+ -- Look for rules or specialisations that match
+ --
+ -- It's important to simplify the args first, because the rule-matcher
+ -- doesn't do substitution as it goes. We don't want to use subst_args
+ -- (defined in the 'where') because that throws away useful occurrence info,
+ -- and perhaps-very-important specialisations.
+ --
+ -- Some functions have specialisations *and* are strict; in this case,
+ -- we don't want to inline the wrapper of the non-specialised thing; better
+ -- to call the specialised thing instead.
+ -- But the black-listing mechanism means that inlining of the wrapper
+ -- won't occur for things that have specialisations till a later phase, so
+ -- it's ok to try for inlining first.
+ getSwitchChecker `thenSmpl` \ chkr ->
+ if switchIsOn chkr DontApplyRules then
+ -- Don't try rules
+ rebuild (mkApps (Var var) args') cont'
+ else
+ -- Try rules first
+ case lookupRule in_scope var args' of
+ Just (rule_name, rule_rhs, rule_args) ->
+ tick (RuleFired rule_name) `thenSmpl_`
+ zapSubstEnv (simplExprF rule_rhs (pushArgs emptySubstEnv rule_args cont'))
+ -- See note above about zapping the substitution here
+
+ Nothing -> rebuild (mkApps (Var var) args') cont'
where
get_str var = case getIdStrictness var of
NoStrictnessInfo -> (repeat wwLazy, False)
StrictnessInfo demands result_bot -> (demands, result_bot)
-
- (args', result_cont) = contArgs in_scope cont
- inline_call = contIsInline result_cont
- interesting_cont = contIsInteresting result_cont
- discard_inline_cont | inline_call = discardInline cont
- | otherwise = cont
-
---------- Unfolding stuff
- maybe_inline = callSiteInline black_listed inline_call
- var args' interesting_cont
+ (subst_args, result_cont) = contArgs in_scope cont
+ val_args = filter isValArg subst_args
+ arg_infos = map (interestingArg in_scope) val_args
+ inline_call = contIsInline result_cont
+ interesting_cont = contIsInteresting result_cont
+ discard_inline_cont | inline_call = discardInline cont
+ | otherwise = cont
+
+ maybe_inline = callSiteInline black_listed inline_call occ
+ var arg_infos interesting_cont
Just unf_template = maybe_inline
black_listed = black_list_fn var
- ---------- Specialisation stuff
- maybe_rule_match = lookupRule in_scope var args'
- Just (rule_name, rule_rhs, rule_args) = maybe_rule_match
+
+-- An argument is interesting if it has *some* structure
+-- We are here trying to avoid unfolding a function that
+-- is applied only to variables that have no unfolding
+-- (i.e. they are probably lambda bound): f x y z
+-- There is little point in inlining f here.
+interestingArg in_scope (Type _) = False
+interestingArg in_scope (App fn (Type _)) = interestingArg in_scope fn
+interestingArg in_scope (Var v) = hasSomeUnfolding (getIdUnfolding v')
+ where
+ v' = case lookupVarSet in_scope v of
+ Just v' -> v'
+ other -> v
+interestingArg in_scope other = True
-- First a special case
ty_arg' = substTy (mkSubst in_scope se) ty_arg
res_ty = applyTy fun_ty ty_arg'
in
+ seqType ty_arg' `seq`
go (Type ty_arg' : acc) ds res_ty cont
-- Value argument
%* *
%************************************************************************
+NB: At one time I tried not pre/post-inlining top-level things,
+even if they occur exactly once. Reason:
+ (a) some might appear as a function argument, so we simply
+ replace static allocation with dynamic allocation:
+ l = <...>
+ x = f x
+ becomes
+ x = f <...>
+
+ (b) some top level things might be black listed
+
+HOWEVER, I found that some useful foldr/build fusion was lost (most
+notably in spectral/hartel/parstof) because the foldr didn't see the build.
+
+Doing the dynamic allocation isn't a big deal, in fact, but losing the
+fusion can be.
+
\begin{code}
-preInlineUnconditionally :: InId -> Bool
+preInlineUnconditionally :: Bool {- Black listed -} -> InId -> Bool
-- Examines a bndr to see if it is used just once in a
-- completely safe way, so that it is safe to discard the binding
-- inline its RHS at the (unique) usage site, REGARDLESS of how
--
-- Evne RHSs labelled InlineMe aren't caught here, because
-- there might be no benefit from inlining at the call site.
- -- But things labelled 'IMustBeINLINEd' *are* caught. We use this
- -- for the trivial bindings introduced by SimplUtils.mkRhsTyLam
-preInlineUnconditionally bndr
- = case getInlinePragma bndr of
- IMustBeINLINEd -> True
- ICanSafelyBeINLINEd NotInsideLam True -> True -- Not inside a lambda,
- -- one occurrence ==> safe!
- other -> False
+preInlineUnconditionally black_listed bndr
+ | black_listed || opt_SimplNoPreInlining = False
+ | otherwise = case getIdOccInfo bndr of
+ OneOcc in_lam once -> not in_lam && once
+ -- Not inside a lambda, one occurrence ==> safe!
+ other -> False
-postInlineUnconditionally :: InId -> OutExpr -> Bool
+
+postInlineUnconditionally :: Bool -- Black listed
+ -> OccInfo
+ -> InId -> OutExpr -> Bool
-- Examines a (bndr = rhs) binding, AFTER the rhs has been simplified
-- It returns True if it's ok to discard the binding and inline the
-- RHS at every use site.
-- We're at the binding site right now, and
-- we'll get another opportunity when we get to the ocurrence(s)
-postInlineUnconditionally bndr rhs
- | isExportedId bndr
- = False
- | otherwise
- = case getInlinePragma bndr of
- IAmALoopBreaker -> False
-
- ICanSafelyBeINLINEd InsideLam one_branch -> exprIsTrivial rhs
- -- Don't inline even WHNFs inside lambdas; doing so may
- -- simply increase allocation when the function is called
- -- This isn't the last chance; see NOTE above.
-
- ICanSafelyBeINLINEd not_in_lam one_branch -> one_branch || exprIsTrivial rhs
- -- Was 'exprIsDupable' instead of 'exprIsTrivial' but the
- -- decision about duplicating code is best left to callSiteInline
-
- other -> exprIsTrivial rhs -- Duplicating is *free*
- -- NB: Even InlineMe and IMustBeINLINEd are ignored here
- -- Why? Because we don't even want to inline them into the
- -- RHS of constructor arguments. See NOTE above
- -- NB: Even IMustBeINLINEd is ignored here: if the rhs is trivial
- -- it's best to inline it anyway. We often get a=E; b=a
- -- from desugaring, with both a and b marked NOINLINE.
+postInlineUnconditionally black_listed occ_info bndr rhs
+ | isExportedId bndr ||
+ black_listed ||
+ loop_breaker = False -- Don't inline these
+ | otherwise = exprIsTrivial rhs -- Duplicating is free
+ -- Don't inline even WHNFs inside lambdas; doing so may
+ -- simply increase allocation when the function is called
+ -- This isn't the last chance; see NOTE above.
+ --
+ -- NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here
+ -- Why? Because we don't even want to inline them into the
+ -- RHS of constructor arguments. See NOTE above
+ --
+ -- NB: Even NOINLINEis ignored here: if the rhs is trivial
+ -- it's best to inline it anyway. We often get a=E; b=a
+ -- from desugaring, with both a and b marked NOINLINE.
+ where
+ loop_breaker = case occ_info of
+ IAmALoopBreaker -> True
+ other -> False
\end{code}
all (cheapEqExpr rhs1) other_rhss && all binders_unused alts
-- Check that the scrutinee can be let-bound instead of case-bound
- && ( (isUnLiftedType (idType bndr) && -- It's unlifted and floatable
- exprOkForSpeculation scrut) -- NB: scrut = an unboxed variable satisfies
+ && ( exprOkForSpeculation scrut
+ -- OK not to evaluate it
+ -- This includes things like (==# a# b#)::Bool
+ -- so that we simplify
+ -- case ==# a# b# of { True -> x; False -> x }
+ -- to just
+ -- x
+ -- This particular example shows up in default methods for
+ -- comparision operations (e.g. in (>=) for Int.Int32)
|| exprIsValue scrut -- It's already evaluated
|| var_demanded_later scrut -- It'll be demanded later
-- Get rid of the case altogether
-- See the extensive notes on case-elimination below
-- Remember to bind the binder though!
- = tick (CaseElim bndr) `thenSmpl_` (
- setSubstEnv se $
- simplBinder bndr $ \ bndr' ->
- completeBinding bndr bndr' scrut $
+ = tick (CaseElim bndr) `thenSmpl_` (
+ setSubstEnv se $
+ simplBinder bndr $ \ bndr' ->
+ completeBinding bndr bndr' False False scrut $
simplExprF rhs1 cont)
| otherwise
-- Deal with variable scrutinee
- ( simplBinder case_bndr $ \ case_bndr' ->
- substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
- let
- case_bndr'' = zap_occ_info case_bndr'
- in
+ ( simplCaseBinder scrut case_bndr $ \ case_bndr' zap_occ_info ->
- -- Deal with the case alternaatives
+ -- Deal with the case alternatives
simplAlts zap_occ_info scrut_cons
- case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
+ case_bndr' better_alts cont' `thenSmpl` \ alts' ->
- mkCase scrut case_bndr'' alts'
+ mkCase scrut case_bndr' alts'
) `thenSmpl` \ case_expr ->
-- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope
simplBinder bndr $ \ bndr' ->
case findAlt con alts of
(DEFAULT, bs, rhs) -> ASSERT( null bs )
- completeBinding bndr bndr' expr $
+ completeBinding bndr bndr' False False expr $
-- Don't use completeBeta here. The expr might be
-- an unboxed literal, like 3, or a variable
-- whose unfolding is an unboxed literal... and
simplExprF rhs cont
(DataCon dc, bs, rhs) -> ASSERT( length bs == length real_args )
- completeBinding bndr bndr' expr $
+ completeBinding bndr bndr' False False expr $
-- See note above
extendSubstList bs (map mk real_args) $
simplExprF rhs cont
-- Polymorphic recursion here!
prepareCaseCont [alt] cont thing_inside = thing_inside cont
-prepareCaseCont alts cont thing_inside = mkDupableCont (coreAltsType alts) cont thing_inside
+prepareCaseCont alts cont thing_inside = simplType (coreAltsType alts) `thenSmpl` \ alts_ty ->
+ mkDupableCont alts_ty cont thing_inside
+ -- At one time I passed in the un-simplified type, and simplified
+ -- it only if we needed to construct a join binder, but that
+ -- didn't work because we have to decompse function types
+ -- (using funResultTy) in mkDupableCont.
\end{code}
-substForVarScrut checks whether the scrutinee is a variable, v.
+simplCaseBinder checks whether the scrutinee is a variable, v.
If so, try to eliminate uses of v in the RHSs in favour of case_bndr;
that way, there's a chance that v will now only be used once, and hence inlined.
case x or { (a,b) -> a b }
Urk! b is alive! Reason: the scrutinee was a variable, and case elimination
-happened. Hence the zap_occ_info function returned by substForVarScrut
+happened. Hence the zap_occ_info function returned by simplCaseBinder
\begin{code}
-substForVarScrut (Var v) case_bndr' thing_inside
- | isLocallyDefined v -- No point for imported things
- = modifyInScope (v `setIdUnfolding` mkUnfolding (Var case_bndr')
- `setInlinePragma` IMustBeINLINEd) $
+simplCaseBinder (Var v) case_bndr thing_inside
+ = simplBinder (zap case_bndr) $ \ case_bndr' ->
+ modifyInScope v case_bndr' $
-- We could extend the substitution instead, but it would be
-- a hack because then the substitution wouldn't be idempotent
- -- any more.
- thing_inside (\ bndr -> bndr `setInlinePragma` NoInlinePragInfo)
+ -- any more (v is an OutId). And this just just as well.
+ thing_inside case_bndr' zap
+ where
+ zap b = b `setIdOccInfo` NoOccInfo
-substForVarScrut other_scrut case_bndr' thing_inside
- = thing_inside (\ bndr -> bndr) -- NoOp on bndr
+simplCaseBinder other_scrut case_bndr thing_inside
+ = simplBinder case_bndr $ \ case_bndr' ->
+ thing_inside case_bndr' (\ bndr -> bndr) -- NoOp on bndr
\end{code}
prepareCaseAlts does two things:
----------------------
-simplAlts zap_occ_info scrut_cons case_bndr'' alts cont'
+simplAlts zap_occ_info scrut_cons case_bndr' alts cont'
= mapSmpl simpl_alt alts
where
- inst_tys' = case splitTyConApp_maybe (idType case_bndr'') of
+ inst_tys' = case splitTyConApp_maybe (idType case_bndr') of
Just (tycon, inst_tys) -> inst_tys
-- handled_cons is all the constructors that are dealt
= -- 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` mkOtherCon handled_cons) $
+ modifyInScope case_bndr' (case_bndr' `setIdUnfolding` mkOtherCon handled_cons) $
simplExprC rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (DEFAULT, [], rhs')
simpl_alt (con, vs, rhs)
= -- 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' ->
+ -- as certainly-evaluated.
+ -- NB: it happens that simplBinders does *not* erase the OtherCon
+ -- form of unfolding, so it's ok to add this info before
+ -- doing simplBinders
+ simplBinders (add_evals con vs) $ \ vs' ->
-- Bind the case-binder to (Con args)
let
con_app = Con con (map Type inst_tys' ++ map varToCoreExpr vs')
in
- modifyInScope (case_bndr'' `setIdUnfolding` mkUnfolding con_app) $
+ modifyInScope case_bndr' (case_bndr' `setIdUnfolding` mkUnfolding False con_app) $
simplExprC rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (con, vs', rhs')
%************************************************************************
\begin{code}
-mkDupableCont :: InType -- Type of the thing to be given to the continuation
+mkDupableCont :: OutType -- Type of the thing to be given to the continuation
-> SimplCont
-> (SimplCont -> SimplM (OutStuff a))
-> SimplM (OutStuff a)
mkDupableCont join_arg_ty (ArgOf _ cont_ty cont_fn) thing_inside
= -- Build the RHS of the join point
- simplType join_arg_ty `thenSmpl` \ join_arg_ty' ->
- newId join_arg_ty' ( \ arg_id ->
- getSwitchChecker `thenSmpl` \ chkr ->
+ newId join_arg_ty ( \ arg_id ->
cont_fn (Var arg_id) `thenSmpl` \ (binds, (_, rhs)) ->
- returnSmpl (Lam arg_id (mkLets binds rhs))
+ returnSmpl (Lam (setOneShotLambda arg_id) (mkLets binds rhs))
) `thenSmpl` \ join_rhs ->
-- Build the join Id and continuation
new_cont = ArgOf OkToDup cont_ty
(\arg' -> rebuild_done (App (Var join_id) arg'))
in
-
- -- Do the thing inside
+
+ tick (CaseOfCase join_id) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code;
+ -- not strictly CaseOf Case
thing_inside new_cont `thenSmpl` \ res ->
returnSmpl (addBind (NonRec join_id join_rhs) res)
thing_inside (ApplyTo OkToDup arg' emptySubstEnv cont')
else
newId (coreExprType arg') $ \ bndr ->
+
+ tick (CaseOfCase bndr) `thenSmpl_`
+ -- Want to tick here so that we go round again,
+ -- and maybe copy or inline the code;
+ -- not strictly CaseOf Case
thing_inside (ApplyTo OkToDup (Var bndr) emptySubstEnv cont') `thenSmpl` \ res ->
returnSmpl (addBind (NonRec bndr arg') res)
mkDupableAlt :: InId -> OutId -> SimplCont -> InAlt -> SimplM (OutStuff InAlt)
mkDupableAlt case_bndr case_bndr' cont alt@(con, bndrs, rhs)
- = -- Not worth checking whether the rhs is small; the
- -- inliner will inline it if so.
- simplBinders bndrs $ \ bndrs' ->
+ = simplBinders bndrs $ \ bndrs' ->
simplExprC rhs cont `thenSmpl` \ rhs' ->
+
+ if (case cont of { Stop _ -> exprIsDupable rhs'; other -> False}) then
+ -- It is worth checking for a small RHS because otherwise we
+ -- get extra let bindings that may cause an extra iteration of the simplifier to
+ -- inline back in place. Quite often the rhs is just a variable or constructor.
+ -- The Ord instance of Maybe in PrelMaybe.lhs, for example, took several extra
+ -- iterations because the version with the let bindings looked big, and so wasn't
+ -- inlined, but after the join points had been inlined it looked smaller, and so
+ -- was inlined.
+ --
+ -- But since the continuation is absorbed into the rhs, we only do this
+ -- for a Stop continuation.
+ --
+ -- NB: we have to check the size of rhs', not rhs.
+ -- Duplicating a small InAlt might invalidate occurrence information
+ -- However, if it *is* dupable, we return the *un* simplified alternative,
+ -- because otherwise we'd need to pair it up with an empty subst-env.
+ -- (Remember we must zap the subst-env before re-simplifying something).
+ -- Rather than do this we simply agree to re-simplify the original (small) thing later.
+ returnSmpl ([], alt)
+
+ else
let
rhs_ty' = coreExprType rhs'
(used_bndrs, used_bndrs')
projects / ghc-hetmet.git / blobdiff