Commit c34d93da authored by simonpj's avatar simonpj
Browse files

[project @ 1999-06-22 16:30:06 by simonpj]

Remove exponential simplifier run-time bug
parent edd06d67
......@@ -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}
......
......@@ -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}
%************************************************************************
%* *
......
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