import CmdLineOpts ( intSwitchSet,
opt_SccProfilingOn, opt_PprStyle_Debug, opt_SimplDoEtaReduction,
opt_SimplNoPreInlining, opt_DictsStrict, opt_SimplPedanticBottoms,
- opt_SimplDoCaseElim,
SimplifierSwitch(..)
)
import SimplMonad
getIdDemandInfo, setIdDemandInfo,
getIdArity, setIdArity,
getIdStrictness,
- setInlinePragma, getInlinePragma, idMustBeINLINEd
+ setInlinePragma, getInlinePragma, idMustBeINLINEd,
+ setOneShotLambda
)
import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..),
ArityInfo(..), atLeastArity, arityLowerBound, unknownArity,
import Name ( isLocallyDefined )
import CoreSyn
import CoreFVs ( exprFreeVars )
-import CoreUnfold ( Unfolding(..), mkUnfolding, callSiteInline,
- isEvaldUnfolding, blackListed )
-import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
- coreExprType, coreAltsType, exprIsCheap, exprArity,
- exprOkForSpeculation,
- FormSummary(..), mkFormSummary, whnfOrBottom
+import CoreUnfold ( Unfolding, mkOtherCon, mkUnfolding, otherCons,
+ callSiteInline, blackListed
+ )
+import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsCheap, exprIsTrivial,
+ coreExprType, coreAltsType, exprArity, exprIsValue,
+ exprOkForSpeculation
)
import Rules ( lookupRule )
import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
simplRecBind NotTopLevel pairs bndrs' (simplExprF body cont)
simplExprF expr@(Lam _ _) cont = simplLam expr cont
+
simplExprF (Type ty) cont
= ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } )
simplType ty `thenSmpl` \ ty' ->
-> Int -- Number of args
-> Id -> Id -- Use this to zap the binders
mkLamBndrZapper fun n_args
- | saturated fun n_args = \b -> b
- | otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b
+ | n_args >= n_params fun = \b -> b -- Enough args
+ | otherwise = \b -> maybeModifyIdInfo zapLamIdInfo b
where
- saturated (Lam b e) 0 = False
- saturated (Lam b e) n = saturated e (n-1)
- saturated e n = True
+ n_params (Lam b e) | isId b = 1 + n_params e
+ | otherwise = n_params e
+ n_params other = 0::Int
\end{code}
(floats_out, rhs'') | float_ubx = (floats, rhs')
| otherwise = splitFloats floats rhs'
in
- if (isTopLevel top_lvl || exprIsWHNF rhs') && -- Float lets if (a) we're at the top level
- not (null floats_out) -- or (b) it exposes a HNF
+ 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
then
tickLetFloat floats_out `thenSmpl_`
-- Do the float
#ifdef DEBUG
if isLocallyDefined var && not (idMustBeINLINEd var)
-- The idMustBeINLINEd test accouunts for the fact
- -- that class method selectors don't have top level
+ -- that class dictionary constructors don't have top level
-- bindings and hence aren't in scope.
then
-- Not in scope
in
getBlackList `thenSmpl` \ black_list ->
getInScope `thenSmpl` \ in_scope ->
+ completeCall black_list in_scope 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
+
+ -- Look for an unfolding. There's a binding for the
+ -- thing, but perhaps we want to inline it anyway
+ | maybeToBool maybe_inline
+ = tick (UnfoldingDone var) `thenSmpl_`
+ zapSubstEnv (completeInlining var unf_template discard_inline_cont)
+ -- The template is already simplified, so don't re-substitute.
+ -- This is VITAL. Consider
+ -- let x = e in
+ -- let y = \z -> ...x... in
+ -- \ x -> ...y...
+ -- We'll clone the inner \x, adding x->x' in the id_subst
+ -- Then when we inline y, we must *not* replace x by x' in
+ -- the inlined copy!!
+
+ | otherwise -- Neither rule nor inlining
+ -- Use prepareArgs to use function strictness
+ = prepareArgs (ppr var) (idType var) (get_str var) cont $ \ args' cont' ->
+ rebuild (mkApps (Var var) args') cont'
- prepareArgs (ppr var') (idType var') (get_str var') cont $ \ args' cont' ->
- completeCall black_list in_scope 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
+ 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
+
+-- First a special case
+-- Don't actually inline the scrutinee when we see
+-- case x of y { .... }
+-- and x has unfolding (C a b). Why not? Because
+-- we get a silly binding y = C a b. If we don't
+-- inline knownCon can directly substitute x for y instead.
+completeInlining var (Con con con_args) (Select _ bndr alts se cont)
+ | conOkForAlt con
+ = knownCon (Var var) con con_args bndr alts se cont
+
+-- Now the normal case
+completeInlining var unfolding cont
+ = simplExprF unfolding cont
+
+----------- costCentreOk
+-- costCentreOk checks that it's ok to inline this thing
+-- The time it *isn't* is this:
+--
+-- f x = let y = E in
+-- scc "foo" (...y...)
+--
+-- Here y has a "current cost centre", and we can't inline it inside "foo",
+-- regardless of whether E is a WHNF or not.
+
+costCentreOk ccs_encl cc_rhs
+ = not opt_SccProfilingOn
+ || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
+ || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding
+\end{code}
+
+
+\begin{code}
---------------------------------------------------------
-- Preparing arguments for a call
tick_case_of_error (Stop _) = returnSmpl ()
tick_case_of_error (CoerceIt _ (Stop _)) = returnSmpl ()
tick_case_of_error other = tick BottomFound
-
----------------------------------------------------------
--- Dealing with a call
-
-completeCall black_list_fn in_scope var args 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 (completeApp rule_rhs rule_args cont)
- -- See note below about zapping the substitution here
-
- -- Look for an unfolding. There's a binding for the
- -- thing, but perhaps we want to inline it anyway
- | maybeToBool maybe_inline
- = tick (UnfoldingDone var) `thenSmpl_`
- zapSubstEnv (completeInlining var unf_template args (discardInlineCont cont))
- -- The template is already simplified, so don't re-substitute.
- -- This is VITAL. Consider
- -- let x = e in
- -- let y = \z -> ...x... in
- -- \ x -> ...y...
- -- We'll clone the inner \x, adding x->x' in the id_subst
- -- Then when we inline y, we must *not* replace x by x' in
- -- the inlined copy!!
-
- | otherwise -- Neither rule nor inlining
- = rebuild (mkApps (Var var) args) cont
-
- where
- ---------- Unfolding stuff
- maybe_inline = callSiteInline black_listed inline_call
- var args interesting_cont
- Just unf_template = maybe_inline
- interesting_cont = contIsInteresting cont
- inline_call = contIsInline cont
- 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
-
-
--- First a special case
--- Don't actually inline the scrutinee when we see
--- case x of y { .... }
--- and x has unfolding (C a b). Why not? Because
--- we get a silly binding y = C a b. If we don't
--- inline knownCon can directly substitute x for y instead.
-completeInlining var (Con con con_args) args (Select _ bndr alts se cont)
- | conOkForAlt con
- = ASSERT( null args )
- knownCon (Var var) con con_args bndr alts se cont
-
--- Now the normal case
-completeInlining var unfolding args cont
- = completeApp unfolding args cont
-
--- completeApp applies a new InExpr (from an unfolding or rule)
--- to an *already simplified* set of arguments
-completeApp :: InExpr -- (\xs. body)
- -> [OutExpr] -- Args; already simplified
- -> SimplCont -- What to do with result of applicatoin
- -> SimplM OutExprStuff
-completeApp fun args cont
- = go fun args
- where
- zap_it = mkLamBndrZapper fun (length args)
- cont_ty = contResultType cont
-
- -- These equations are very similar to simplLam and simplBeta combined,
- -- except that they deal with already-simplified arguments
-
- -- Type argument
- go (Lam bndr fun) (Type ty:args) = tick (BetaReduction bndr) `thenSmpl_`
- extendSubst bndr (DoneTy ty)
- (go fun args)
-
- -- Value argument
- go (Lam bndr fun) (arg:args)
- | preInlineUnconditionally bndr && not opt_SimplNoPreInlining
- = tick (BetaReduction bndr) `thenSmpl_`
- tick (PreInlineUnconditionally bndr) `thenSmpl_`
- extendSubst bndr (DoneEx arg)
- (go fun args)
- | otherwise
- = tick (BetaReduction bndr) `thenSmpl_`
- simplBinder zapped_bndr ( \ bndr' ->
- completeBeta zapped_bndr bndr' arg $
- go fun args
- )
- where
- zapped_bndr = zap_it bndr
-
- -- Consumed all the lambda binders or args
- go fun args = simplExprF fun (pushArgs emptySubstEnv args cont)
-
-
------------ costCentreOk
--- costCentreOk checks that it's ok to inline this thing
--- The time it *isn't* is this:
---
--- f x = let y = E in
--- scc "foo" (...y...)
---
--- Here y has a "current cost centre", and we can't inline it inside "foo",
--- regardless of whether E is a WHNF or not.
-
-costCentreOk ccs_encl cc_rhs
- = not opt_SccProfilingOn
- || isSubsumedCCS ccs_encl -- can unfold anything into a subsumed scope
- || not (isEmptyCC cc_rhs) -- otherwise need a cc on the unfolding
-\end{code}
-
+\end{code}
%************************************************************************
%* *
-- for the trivial bindings introduced by SimplUtils.mkRhsTyLam
preInlineUnconditionally bndr
= case getInlinePragma bndr of
- IMustBeINLINEd -> True
- ICanSafelyBeINLINEd InsideLam _ -> False
- ICanSafelyBeINLINEd not_in_lam True -> True -- Not inside a lambda,
+ IMustBeINLINEd -> True
+ ICanSafelyBeINLINEd NotInsideLam True -> True -- Not inside a lambda,
-- one occurrence ==> safe!
other -> False
-- from desugaring, with both a and b marked NOINLINE.
\end{code}
-\begin{code}
-inlineCase bndr scrut
- = exprIsTrivial scrut -- Duplication is free
- && ( isUnLiftedType (idType bndr)
- || scrut_is_evald_var -- So dropping the case won't change termination
- || isStrict (getIdDemandInfo bndr) -- It's going to get evaluated later, so again
- -- termination doesn't change
- || not opt_SimplPedanticBottoms) -- Or we don't care!
- where
- -- Check whether or not scrut is known to be evaluted
- -- It's not going to be a visible value (else the previous
- -- blob would apply) so we just check the variable case
- scrut_is_evald_var = case scrut of
- Var v -> isEvaldUnfolding (getIdUnfolding v)
- other -> False
-\end{code}
-
%************************************************************************
| conOkForAlt con -- Knocks out PrimOps and NoRepLits
= knownCon expr con args bndr alts se cont
--- Case of other value (e.g. a partial application or lambda)
--- Turn it back into a let
-rebuild scrut (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont)
- | isUnLiftedType (idType bndr) && exprOkForSpeculation scrut
- || exprIsWHNF scrut
- = ASSERT( null bs && null alts )
- setSubstEnv se $
- simplBinder bndr $ \ bndr' ->
- completeBinding bndr bndr' scrut $
- simplExprF rhs cont
-
---------------------------------------------------------
-- The other Select cases
rebuild scrut (Select _ bndr alts se cont)
- | all (cheapEqExpr rhs1) other_rhss
- && inlineCase bndr scrut
- && all binders_unused alts
- && opt_SimplDoCaseElim
- = -- Get rid of the case altogether
+ | -- Check that the RHSs are all the same, and
+ -- don't use the binders in the alternatives
+ -- This test succeeds rapidly in the common case of
+ -- a single DEFAULT alternative
+ 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
+ || exprIsValue scrut -- It's already evaluated
+ || var_demanded_later scrut -- It'll be demanded later
+
+-- || not opt_SimplPedanticBottoms) -- Or we don't care!
+-- We used to allow improving termination by discarding cases, unless -fpedantic-bottoms was on,
+-- but that breaks badly for the dataToTag# primop, which relies on a case to evaluate
+-- its argument: case x of { y -> dataToTag# y }
+-- Here we must *not* discard the case, because dataToTag# just fetches the tag from
+-- the info pointer. So we'll be pedantic all the time, and see if that gives any
+-- other problems
+ )
+
+-- && opt_SimplDoCaseElim
+-- [June 99; don't test this flag. The code generator dies if it sees
+-- case (\x.e) of f -> ...
+-- so better to always do it
+
+ -- 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 (
- extendSubst bndr (DoneEx scrut) $
- simplExprF rhs1 cont
- )
+ = tick (CaseElim bndr) `thenSmpl_` (
+ setSubstEnv se $
+ simplBinder bndr $ \ bndr' ->
+ completeBinding bndr bndr' scrut $
+ simplExprF rhs1 cont)
+
| otherwise
= rebuild_case scrut bndr alts se cont
where
(rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts]
binders_unused (_, bndrs, _) = all isDeadBinder bndrs
+
+ var_demanded_later (Var v) = isStrict (getIdDemandInfo bndr) -- It's going to be evaluated later
+ var_demanded_later other = False
\end{code}
Case elimination [see the code above]
-- Deal with the case binder, and prepare the continuation;
-- The new subst_env is in place
- simplBinder case_bndr $ \ case_bndr' ->
prepareCaseCont better_alts cont $ \ cont' ->
-- Deal with variable scrutinee
- substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
- let
- case_bndr'' = zap_occ_info case_bndr'
- in
+ ( simplBinder case_bndr $ \ case_bndr' ->
+ substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
+ let
+ case_bndr'' = zap_occ_info case_bndr'
+ in
-- Deal with the case alternaatives
- simplAlts zap_occ_info scrut_cons
- case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
+ simplAlts zap_occ_info scrut_cons
+ case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
+
+ mkCase scrut case_bndr'' alts'
+ ) `thenSmpl` \ case_expr ->
- mkCase scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
+ -- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope
+ -- over the rebuild_done; rebuild_done returns the in-scope set, and
+ -- that should not include these chaps!
rebuild_done case_expr
where
-- scrut_cons tells what constructors the scrutinee can't possibly match
scrut_cons = case scrut of
- Var v -> case getIdUnfolding v of
- OtherCon cons -> cons
- other -> []
+ Var v -> otherCons (getIdUnfolding v)
other -> []
= -- 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) $
+ modifyInScope (case_bndr'' `setIdUnfolding` mkOtherCon handled_cons) $
simplExprC rhs cont' `thenSmpl` \ rhs' ->
returnSmpl (DEFAULT, [], rhs')
cat_evals [] [] = []
cat_evals (v:vs) (str:strs)
- | isTyVar v = v : cat_evals vs (str:strs)
- | isStrict str = (v' `setIdUnfolding` OtherCon []) : cat_evals vs strs
- | otherwise = v' : cat_evals vs strs
+ | isTyVar v = v : cat_evals vs (str:strs)
+ | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs
+ | otherwise = v' : cat_evals vs strs
where
v' = zap_occ_info v
\end{code}
--
-- Now CPR should not w/w j because it's a thunk, so
-- that means that the enclosing function can't w/w either,
- -- which is a BIG LOSE. This actually happens in practice
+ -- which is a lose. Here's the example that happened in practice:
+ -- kgmod :: Int -> Int -> Int
+ -- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
+ -- then 78
+ -- else 5
+
then newId realWorldStatePrimTy $ \ rw_id ->
returnSmpl ([rw_id], [Var realWorldPrimId])
else
`thenSmpl` \ (final_bndrs', final_args) ->
newId (foldr (mkFunTy . idType) rhs_ty' final_bndrs') $ \ join_bndr ->
- returnSmpl ([NonRec join_bndr (mkLams final_bndrs' rhs')],
+
+ -- Notice that we make the lambdas into one-shot-lambdas. The
+ -- join point is sure to be applied at most once, and doing so
+ -- prevents the body of the join point being floated out by
+ -- the full laziness pass
+ returnSmpl ([NonRec join_bndr (mkLams (map setOneShotLambda final_bndrs') rhs')],
(con, bndrs, mkApps (Var join_bndr) final_args))
\end{code}
projects / ghc-hetmet.git / blobdiff