diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs
index 5b5cde807223272b24b16a48c5eedcc08e56871f..32d8d6b002f20a899503467aac180a6bbcf6ef90 100644
--- a/ghc/compiler/simplCore/SimplMonad.lhs
+++ b/ghc/compiler/simplCore/SimplMonad.lhs
@@ -12,7 +12,7 @@ module SimplMonad (
-- The continuation type
SimplCont(..), DupFlag(..), contIsDupable, contResultType,
contIsInteresting, pushArgs, discardCont, countValArgs, countArgs,
- contIsInline, discardInlineCont,
+ contArgs, contIsInline, discardInline,
-- The monad
SimplM,
@@ -62,7 +62,7 @@ import VarEnv
import VarSet
import qualified Subst
import Subst ( Subst, emptySubst, mkSubst,
- substTy, substEnv,
+ substTy, substEnv, substExpr,
InScopeSet, substInScope, isInScope, lookupInScope
)
import Type ( Type, TyVarSubst, applyTy )
@@ -172,13 +172,24 @@ contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable (InlinePlease cont) = contIsDupable cont
contIsDupable other = False
+contArgs :: InScopeSet -> SimplCont -> ([OutExpr], SimplCont)
+ -- Get the arguments from the continuation
+ -- Apply the appropriate substitution first;
+ -- this is done lazily and typically only the bit at the top is used
+contArgs in_scope (ApplyTo _ e s cont)
+ = case contArgs in_scope cont of
+ (args, result) -> (substExpr (mkSubst in_scope s) e : args, result)
+contArgs in_scope result_cont
+ = ([], result_cont)
+
contIsInline :: SimplCont -> Bool
contIsInline (InlinePlease cont) = True
contIsInline other = False
-discardInlineCont :: SimplCont -> SimplCont
-discardInlineCont (InlinePlease cont) = cont
-discardInlineCont cont = cont
+discardInline :: SimplCont -> SimplCont
+discardInline (InlinePlease cont) = cont
+discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
+discardInline cont = cont
\end{code}
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 03ad9eb9308e860c57bf08fec812e2551074e071..9de7090bb00f2daaeb4a81d9d0a2af05b983e07f 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -700,15 +700,96 @@ simplVar var cont
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
@@ -768,123 +849,7 @@ prepareArgs pp_fun orig_fun_ty (fun_demands, result_bot) orig_cont thing_inside
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 zapped_bndr && not opt_SimplNoPreInlining
- = tick (BetaReduction bndr) `thenSmpl_`
- tick (PreInlineUnconditionally bndr) `thenSmpl_`
- extendSubst zapped_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}
%************************************************************************
%* *