\begin{code}
module SimplUtils (
-- Rebuilding
- mkLam, mkCase, prepareAlts,
+ mkLam, mkCase, prepareAlts, tryEtaExpand,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally,
-- The continuation type
SimplCont(..), DupFlag(..), ArgInfo(..),
+ isSimplified,
contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs,
- pushArgs, countValArgs, countArgs, addArgTo,
+ pushSimplifiedArgs, countValArgs, countArgs, addArgTo,
mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
interestingCallContext,
import CoreUnfold
import Name
import Id
-import Var ( isCoVar )
+import Var
import Demand
import SimplMonad
import Type hiding( substTy )
SimplCont
| ApplyTo -- C arg
- DupFlag
- InExpr StaticEnv -- The argument and its static env
+ DupFlag -- See Note [DupFlag invariants]
+ InExpr StaticEnv -- The argument and its static env
SimplCont
| Select -- case C of alts
- DupFlag
+ DupFlag -- See Note [DupFlag invariants]
InId [InAlt] StaticEnv -- The case binder, alts, and subst-env
SimplCont
(nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
ppr (CoerceIt co cont) = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
-data DupFlag = OkToDup | NoDup
+data DupFlag = NoDup -- Unsimplified, might be big
+ | Simplified -- Simplified
+ | OkToDup -- Simplified and small
+
+isSimplified :: DupFlag -> Bool
+isSimplified NoDup = False
+isSimplified _ = True -- Invariant: the subst-env is empty
instance Outputable DupFlag where
- ppr OkToDup = ptext (sLit "ok")
- ppr NoDup = ptext (sLit "nodup")
+ ppr OkToDup = ptext (sLit "ok")
+ ppr NoDup = ptext (sLit "nodup")
+ ppr Simplified = ptext (sLit "simpl")
+\end{code}
+Note [DupFlag invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+In both (ApplyTo dup _ env k)
+ and (Select dup _ _ env k)
+the following invariants hold
+ (a) if dup = OkToDup, then continuation k is also ok-to-dup
+ (b) if dup = OkToDup or Simplified, the subst-env is empty
+ (and and hence no need to re-simplify)
+\begin{code}
-------------------
mkBoringStop :: SimplCont
mkBoringStop = Stop BoringCtxt
-------------------
contIsDupable :: SimplCont -> Bool
contIsDupable (Stop {}) = True
-contIsDupable (ApplyTo OkToDup _ _ _) = True
-contIsDupable (Select OkToDup _ _ _ _) = True
+contIsDupable (ApplyTo OkToDup _ _ _) = True -- See Note [DupFlag invariants]
+contIsDupable (Select OkToDup _ _ _ _) = True -- ...ditto...
contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable _ = False
contArgs cont = (True, [], cont)
-pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
-pushArgs _env [] cont = cont
-pushArgs env (arg:args) cont = ApplyTo NoDup arg env (pushArgs env args cont)
+pushSimplifiedArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
+pushSimplifiedArgs _env [] cont = cont
+pushSimplifiedArgs env (arg:args) cont = ApplyTo Simplified arg env (pushSimplifiedArgs env args cont)
+ -- The env has an empty SubstEnv
dropArgs :: Int -> SimplCont -> SimplCont
dropArgs 0 cont = cont
\end{code}
-
%************************************************************************
%* *
-\subsection{Decisions about inlining}
+ Gentle mode
%* *
%************************************************************************
a) inlining (sm_inline flag)
b) rules (sm_rules flag)
A key invariant about Gentle mode is that it is treated as the EARLIEST
-phase. Something is inlined if the sm_inline flag is on AND the thing
-is inlinable in the earliest phase. This is important. Example
+phase.
+
+\begin{code}
+simplEnvForGHCi :: SimplEnv
+simplEnvForGHCi = mkSimplEnv allOffSwitchChecker $
+ SimplGently { sm_rules = True, sm_inline = False }
+ -- Do not do any inlining, in case we expose some unboxed
+ -- tuple stuff that confuses the bytecode interpreter
+simplEnvForRules :: SimplEnv
+simplEnvForRules = mkSimplEnv allOffSwitchChecker $
+ SimplGently { sm_rules = True, sm_inline = False }
+
+updModeForInlineRules :: Activation -> SimplifierMode -> SimplifierMode
+-- See Note [Simplifying inside InlineRules]
+updModeForInlineRules _inline_rule_act _current_mode
+ = SimplGently { sm_rules = True, sm_inline = True }
+\end{code}
+
+Note [Inlining in gentle mode]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Something is inlined if
+ (i) the sm_inline flag is on, AND
+ (ii) the thing has an INLINE pragma, AND
+ (iii) the thing is inlinable in the earliest phase.
+
+Example of why (iii) is important:
{-# INLINE [~1] g #-}
g = ...
But watch out: list fusion can prevent floating. So use phase control
to switch off those rules until after floating.
+Currently (Oct10) I think that sm_rules is always True, so we
+could remove it.
+
Note [Simplifying inside InlineRules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We must take care with simplification inside InlineRules (which come from
Second, we do want *do* to some modest rules/inlining stuff in InlineRules,
partly to eliminate senseless crap, and partly to break the recursive knots
generated by instance declarations. To keep things simple, we always set
-the phase to 'gentle' when processing InlineRules. OK, so suppose we have
- {-# INLINE <act> f #-}
- f = <rhs>
-meaning "inline f in phases p where activation <act>(p) holds".
-Then what inlinings/rules can we apply to the copy of <rhs> captured in
-f's InlineRule? Our model is that literally <rhs> is substituted for
-f when it is inlined. So our conservative plan (implemented by
-updModeForInlineRules) is this:
-
- -------------------------------------------------------------
- When simplifying the RHS of an InlineRule,
- If the InlineRule becomes active in phase p, then
- if the current phase is *earlier than* p,
- make no inlinings or rules active when simplifying the RHS
- otherwise
- set the phase to p when simplifying the RHS
- -------------------------------------------------------------
-
-That ensures that
-
- a) Rules/inlinings that *cease* being active before p will
- not apply to the InlineRule rhs, consistent with it being
- inlined in its *original* form in phase p.
-
- b) Rules/inlinings that only become active *after* p will
- not apply to the InlineRule rhs, again to be consistent with
- inlining the *original* rhs in phase p.
-
-For example,
- {-# INLINE f #-}
- f x = ...g...
-
- {-# NOINLINE [1] g #-}
- g y = ...
-
- {-# RULE h g = ... #-}
-Here we must not inline g into f's RHS, even when we get to phase 0,
-because when f is later inlined into some other module we want the
-rule for h to fire.
-
-Similarly, consider
- {-# INLINE f #-}
- f x = ...g...
-
- g y = ...
-and suppose that there are auto-generated specialisations and a strictness
-wrapper for g. The specialisations get activation AlwaysActive, and the
-strictness wrapper get activation (ActiveAfter 0). So the strictness
-wrepper fails the test and won't be inlined into f's InlineRule. That
-means f can inline, expose the specialised call to g, so the specialisation
-rules can fire.
+the phase to 'gentle' when processing InlineRules.
A note about wrappers
~~~~~~~~~~~~~~~~~~~~~
continuation.
\begin{code}
-simplEnvForGHCi :: SimplEnv
-simplEnvForGHCi = mkSimplEnv allOffSwitchChecker $
- SimplGently { sm_rules = False, sm_inline = False }
- -- Do not do any inlining, in case we expose some unboxed
- -- tuple stuff that confuses the bytecode interpreter
+activeUnfolding :: SimplEnv -> IdUnfoldingFun
+activeUnfolding env
+ = case getMode env of
+ SimplGently { sm_inline = False } -> active_unfolding_minimal
+ SimplGently { sm_inline = True } -> active_unfolding_gentle
+ SimplPhase n _ -> active_unfolding n
-simplEnvForRules :: SimplEnv
-simplEnvForRules = mkSimplEnv allOffSwitchChecker $
- SimplGently { sm_rules = True, sm_inline = False }
+activeUnfInRule :: SimplEnv -> IdUnfoldingFun
+-- When matching in RULE, we want to "look through" an unfolding
+-- (to see a constructor) if *rules* are on, even if *inlinings*
+-- are not. A notable example is DFuns, which really we want to
+-- match in rules like (op dfun) in gentle mode. Another example
+-- is 'otherwise' which we want exprIsConApp_maybe to be able to
+-- see very early on
+activeUnfInRule env
+ = case getMode env of
+ SimplGently { sm_rules = False } -> active_unfolding_minimal
+ SimplGently { sm_rules = True } -> active_unfolding_early
+ SimplPhase n _ -> active_unfolding n
+ where
+ active_unfolding_early id
+ | isEarlyActive (idInlineActivation id) = idUnfolding id
+ | otherwise = idUnfolding id
-updModeForInlineRules :: Activation -> SimplifierMode -> SimplifierMode
--- See Note [Simplifying inside InlineRules]
--- Treat Gentle as phase "infinity"
--- If current_phase `earlier than` inline_rule_start_phase
--- then no_op
--- else
--- if current_phase `same phase` inline_rule_start_phase
--- then current_phase (keep gentle flags)
--- else inline_rule_start_phase
-updModeForInlineRules inline_rule_act current_mode
- = case inline_rule_act of
- NeverActive -> no_op
- AlwaysActive -> mk_gentle current_mode
- ActiveBefore {} -> mk_gentle current_mode
- ActiveAfter n -> mk_phase n current_mode
+active_unfolding_minimal :: IdUnfoldingFun
+-- Compuslory unfoldings only
+-- Ignore SimplGently, because we want to inline regardless;
+-- the Id has no top-level binding at all
+--
+-- NB: we used to have a second exception, for data con wrappers.
+-- On the grounds that we use gentle mode for rule LHSs, and
+-- they match better when data con wrappers are inlined.
+-- But that only really applies to the trivial wrappers (like (:)),
+-- and they are now constructed as Compulsory unfoldings (in MkId)
+-- so they'll happen anyway.
+active_unfolding_minimal id
+ | isCompulsoryUnfolding unf = unf
+ | otherwise = NoUnfolding
+ where
+ unf = idUnfolding id
+
+active_unfolding_gentle :: IdUnfoldingFun
+-- Anything that is early-active
+-- See Note [Gentle mode]
+active_unfolding_gentle id
+ | isStableUnfolding unf
+ , isEarlyActive (idInlineActivation id) = unf
+ -- NB: wrappers are not early-active
+ | otherwise = NoUnfolding
where
- no_op = SimplGently { sm_rules = False, sm_inline = False }
+ unf = idUnfolding id
+ -- idUnfolding checks for loop-breakers
+ -- Things with an INLINE pragma may have
+ -- an unfolding *and* be a loop breaker
+ -- (maybe the knot is not yet untied)
- mk_gentle (SimplGently {}) = current_mode
- mk_gentle _ = SimplGently { sm_rules = True, sm_inline = True }
+active_unfolding :: CompilerPhase -> IdUnfoldingFun
+active_unfolding n id
+ | isActive n (idInlineActivation id) = idUnfolding id
+ | otherwise = NoUnfolding
- mk_phase n (SimplPhase _ ss) = SimplPhase n ss
- mk_phase n (SimplGently {}) = SimplPhase n ["gentle-rules"]
+activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
+-- Nothing => No rules at all
+activeRule dflags env
+ | not (dopt Opt_EnableRewriteRules dflags)
+ = Nothing -- Rewriting is off
+ | otherwise
+ = case getMode env of
+ SimplGently { sm_rules = rules_on }
+ | rules_on -> Just isEarlyActive -- Note [RULEs enabled in SimplGently]
+ | otherwise -> Nothing
+ SimplPhase n _ -> Just (isActive n)
\end{code}
+--------------------------------------------------------------
+ OLD NOTES, now wrong
+ Preserved just for now (Oct 10)
+--------------------------------------------------------------
+
+ OK, so suppose we have
+ {-# INLINE <act> f #-}
+ f = <rhs>
+ meaning "inline f in phases p where activation <act>(p) holds".
+ Then what inlinings/rules can we apply to the copy of <rhs> captured in
+ f's InlineRule? Our model is that literally <rhs> is substituted for
+ f when it is inlined. So our conservative plan (implemented by
+ updModeForInlineRules) is this:
+
+ -------------------------------------------------------------
+ When simplifying the RHS of an InlineRule,
+ If the InlineRule becomes active in phase p, then
+ if the current phase is *earlier than* p,
+ make no inlinings or rules active when simplifying the RHS
+ otherwise
+ set the phase to p when simplifying the RHS
+
+ -- Treat Gentle as phase "infinity"
+ -- If current_phase `earlier than` inline_rule_start_phase
+ -- then no_op
+ -- else
+ -- if current_phase `same phase` inline_rule_start_phase
+ -- then current_phase (keep gentle flags)
+ -- else inline_rule_start_phase
+ -------------------------------------------------------------
+
+ That ensures that
+
+ a) Rules/inlinings that *cease* being active before p will
+ not apply to the InlineRule rhs, consistent with it being
+ inlined in its *original* form in phase p.
+
+ b) Rules/inlinings that only become active *after* p will
+ not apply to the InlineRule rhs, again to be consistent with
+ inlining the *original* rhs in phase p.
+
+ For example,
+ {-# INLINE f #-}
+ f x = ...g...
+
+ {-# NOINLINE [1] g #-}
+ g y = ...
+
+ {-# RULE h g = ... #-}
+ Here we must not inline g into f's RHS, even when we get to phase 0,
+ because when f is later inlined into some other module we want the
+ rule for h to fire.
+
+ Similarly, consider
+ {-# INLINE f #-}
+ f x = ...g...
+
+ g y = ...
+ and suppose that there are auto-generated specialisations and a strictness
+ wrapper for g. The specialisations get activation AlwaysActive, and the
+ strictness wrapper get activation (ActiveAfter 0). So the strictness
+ wrepper fails the test and won't be inlined into f's InlineRule. That
+ means f can inline, expose the specialised call to g, so the specialisation
+ rules can fire.
+
+--------------------------------------------------------------
+ END OF OLD NOTES
+--------------------------------------------------------------
+
+
+%************************************************************************
+%* *
+ preInlineUnconditionally
+%* *
+%************************************************************************
preInlineUnconditionally
~~~~~~~~~~~~~~~~~~~~~~~~
\end{code}
+%************************************************************************
+%* *
+ postInlineUnconditionally
+%* *
+%************************************************************************
+
postInlineUnconditionally
~~~~~~~~~~~~~~~~~~~~~~~~~
@postInlineUnconditionally@ decides whether to unconditionally inline
-- See Note [pre/postInlineUnconditionally in gentle mode]
SimplPhase n _ -> isActive n act
act = idInlineActivation bndr
-
-activeUnfolding :: SimplEnv -> IdUnfoldingFun
-activeUnfolding env
- = case getMode env of
- SimplGently { sm_inline = False } -> active_unfolding_minimal
- SimplGently { sm_inline = True } -> active_unfolding_gentle
- SimplPhase n _ -> active_unfolding n
-
-activeUnfInRule :: SimplEnv -> IdUnfoldingFun
--- When matching in RULE, we want to "look through" an unfolding
--- if *rules* are on, even if *inlinings* are not. A notable example
--- is DFuns, which really we want to match in rules like (op dfun)
--- in gentle mode.
-activeUnfInRule env
- = case getMode env of
- SimplGently { sm_rules = False } -> active_unfolding_minimal
- SimplGently { sm_rules = True } -> active_unfolding_gentle
- SimplPhase n _ -> active_unfolding n
-
-active_unfolding_minimal :: IdUnfoldingFun
--- Compuslory unfoldings only
--- Ignore SimplGently, because we want to inline regardless;
--- the Id has no top-level binding at all
---
--- NB: we used to have a second exception, for data con wrappers.
--- On the grounds that we use gentle mode for rule LHSs, and
--- they match better when data con wrappers are inlined.
--- But that only really applies to the trivial wrappers (like (:)),
--- and they are now constructed as Compulsory unfoldings (in MkId)
--- so they'll happen anyway.
-active_unfolding_minimal id
- | isCompulsoryUnfolding unf = unf
- | otherwise = NoUnfolding
- where
- unf = realIdUnfolding id -- Never a loop breaker
-
-active_unfolding_gentle :: IdUnfoldingFun
--- Anything that is early-active
--- See Note [Gentle mode]
-active_unfolding_gentle id
- | isEarlyActive (idInlineActivation id) = idUnfolding id
- | otherwise = NoUnfolding
- -- idUnfolding checks for loop-breakers
- -- Things with an INLINE pragma may have
- -- an unfolding *and* be a loop breaker
- -- (maybe the knot is not yet untied)
-
-active_unfolding :: CompilerPhase -> IdUnfoldingFun
-active_unfolding n id
- | isActive n (idInlineActivation id) = idUnfolding id
- | otherwise = NoUnfolding
-
-activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
--- Nothing => No rules at all
-activeRule dflags env
- | not (dopt Opt_EnableRewriteRules dflags)
- = Nothing -- Rewriting is off
- | otherwise
- = case getMode env of
- SimplGently { sm_rules = rules_on }
- | rules_on -> Just isEarlyActive -- Note [RULEs enabled in SimplGently]
- | otherwise -> Nothing
- SimplPhase n _ -> Just (isActive n)
\end{code}
Note [Top level and postInlineUnconditionally]
(bndrs1, body1) = collectBinders body
mkLam' dflags bndrs body
- | dopt Opt_DoEtaReduction dflags,
- Just etad_lam <- tryEtaReduce bndrs body
+ | dopt Opt_DoEtaReduction dflags
+ , Just etad_lam <- tryEtaReduce bndrs body
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
- | dopt Opt_DoLambdaEtaExpansion dflags,
- not (all isTyCoVar bndrs) -- Don't eta expand type abstractions
- = do { let body' = tryEtaExpansion dflags body
- ; return (mkLams bndrs body') }
-
| otherwise
= return (mkLams bndrs body)
\end{code}
+
Note [Casts and lambdas]
~~~~~~~~~~~~~~~~~~~~~~~~
Consider
/\g. e `cast` g ==> (/\g.e) `cast` (/\g.g)
because the latter is not well-kinded.
--- c) floating lets out through big lambdas
--- [only if all tyvar lambdas, and only if this lambda
--- is the RHS of a let]
-
-{- Sept 01: I'm experimenting with getting the
- full laziness pass to float out past big lambdsa
- | all isTyCoVar bndrs, -- Only for big lambdas
- contIsRhs cont -- Only try the rhs type-lambda floating
- -- if this is indeed a right-hand side; otherwise
- -- we end up floating the thing out, only for float-in
- -- to float it right back in again!
- = do (floats, body') <- tryRhsTyLam env bndrs body
- return (floats, mkLams bndrs body')
--}
-
-
%************************************************************************
%* *
- Eta expansion
+ Eta expansion
%* *
%************************************************************************
-
-We go for:
- f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
- (n >= 0)
-
-where (in both cases)
-
- * The xi can include type variables
-
- * The yi are all value variables
-
- * N is a NORMAL FORM (i.e. no redexes anywhere)
- wanting a suitable number of extra args.
-
-The biggest reason for doing this is for cases like
-
- f = \x -> case x of
- True -> \y -> e1
- False -> \y -> e2
-
-Here we want to get the lambdas together. A good exmaple is the nofib
-program fibheaps, which gets 25% more allocation if you don't do this
-eta-expansion.
-
-We may have to sandwich some coerces between the lambdas
-to make the types work. exprEtaExpandArity looks through coerces
-when computing arity; and etaExpand adds the coerces as necessary when
-actually computing the expansion.
-
\begin{code}
-tryEtaExpansion :: DynFlags -> OutExpr -> OutExpr
--- There is at least one runtime binder in the binders
-tryEtaExpansion dflags body
- = etaExpand fun_arity body
+tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr)
+-- See Note [Eta-expanding at let bindings]
+tryEtaExpand env bndr rhs
+ = do { dflags <- getDOptsSmpl
+ ; (new_arity, new_rhs) <- try_expand dflags
+
+ ; WARN( new_arity < old_arity || new_arity < _dmd_arity,
+ (ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_arity
+ <+> ppr new_arity <+> ppr _dmd_arity) $$ ppr new_rhs) )
+ -- Note [Arity decrease]
+ return (new_arity, new_rhs) }
where
- fun_arity = exprEtaExpandArity dflags body
+ try_expand dflags
+ | dopt Opt_DoLambdaEtaExpansion dflags
+ , not (exprIsTrivial rhs)
+ , not (inGentleMode env) -- In gentle mode don't eta-expansion
+ -- because it can clutter up the code
+ -- with casts etc that may not be removed
+ , let new_arity = exprEtaExpandArity dflags rhs
+ , new_arity > old_arity
+ = do { tick (EtaExpansion bndr)
+ ; return (new_arity, etaExpand new_arity rhs) }
+ | otherwise
+ = return (exprArity rhs, rhs)
+
+ old_arity = idArity bndr
+ _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr
\end{code}
+Note [Eta-expanding at let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We now eta expand at let-bindings, which is where the payoff
+comes.
+
+One useful consequence is this example:
+ genMap :: C a => ...
+ {-# INLINE genMap #-}
+ genMap f xs = ...
+
+ myMap :: D a => ...
+ {-# INLINE myMap #-}
+ myMap = genMap
+
+Notice that 'genMap' should only inline if applied to two arguments.
+In the InlineRule for myMap we'll have the unfolding
+ (\d -> genMap Int (..d..))
+We do not want to eta-expand to
+ (\d f xs -> genMap Int (..d..) f xs)
+because then 'genMap' will inline, and it really shouldn't: at least
+as far as the programmer is concerned, it's not applied to two
+arguments!
+
%************************************************************************
%* *