\begin{code}
module SimplUtils (
-- Rebuilding
- mkLam, mkCase, prepareAlts,
+ mkLam, mkCase, prepareAlts, tryEtaExpand,
-- Inlining,
preInlineUnconditionally, postInlineUnconditionally,
import CoreUnfold
import Name
import Id
-import Var ( Var, isCoVar )
+import Var
import Demand
import SimplMonad
import Type hiding( substTy )
\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
- no_op = SimplGently { sm_rules = False, sm_inline = False }
+ unf = idUnfolding id
- mk_gentle (SimplGently {}) = current_mode
- mk_gentle _ = SimplGently { sm_rules = True, sm_inline = True }
+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
+ 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)
+
+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]
= do { tick (EtaReduction (head bndrs))
; return etad_lam }
- | dopt Opt_DoLambdaEtaExpansion dflags
- , any ok_to_expand bndrs
- = do { let body' = etaExpand fun_arity body
- fun_arity = exprEtaExpandArity dflags body
- ; return (mkLams bndrs body') }
-
| otherwise
= return (mkLams bndrs body)
-
- ok_to_expand :: Var -> Bool -- Note [When to eta expand]
- ok_to_expand bndr = isId bndr && not (isDictId bndr)
\end{code}
-Note [When to eta expand]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We only eta expand if there is at least one non-tyvar, non-dict
-binder. The proximate cause for not eta-expanding dictionary lambdas
-was 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!
Note [Casts and lambdas]
~~~~~~~~~~~~~~~~~~~~~~~~
/\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
+%* *
+%************************************************************************
+
+\begin{code}
+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
+ 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!
+
%************************************************************************
%* *
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
import CoreMonad ( SimplifierSwitch(..), Tick(..) )
import CoreSyn
-import Demand ( isStrictDmd, splitStrictSig )
+import Demand ( isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr )
import CoreUnfold ( mkUnfolding, mkCoreUnfolding
, mkInlineUnfolding, mkSimpleUnfolding
, exprIsConApp_maybe, callSiteInline, CallCtxt(..) )
import CoreUtils
import qualified CoreSubst
-import CoreArity ( exprArity )
+import CoreArity
import Rules ( lookupRule, getRules )
import BasicTypes ( isMarkedStrict, Arity )
import CostCentre ( currentCCS, pushCCisNop )
-- * or by adding to the floats in the envt
completeBind env top_lvl old_bndr new_bndr new_rhs
- = do { let old_info = idInfo old_bndr
- old_unf = unfoldingInfo old_info
- occ_info = occInfo old_info
+ = ASSERT( isId new_bndr )
+ do { let old_info = idInfo old_bndr
+ old_unf = unfoldingInfo old_info
+ occ_info = occInfo old_info
- ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf
+ -- Do eta-expansion on the RHS of the binding
+ -- See Note [Eta-expanding at let bindings] in SimplUtils
+ ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs
- ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding
+ -- Simplify the unfolding
+ ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info final_rhs old_unf
+
+ ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding
-- Inline and discard the binding
- then do { tick (PostInlineUnconditionally old_bndr)
- ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> equals <+> ppr new_rhs) $
- return (extendIdSubst env old_bndr (DoneEx new_rhs)) }
+ then do { tick (PostInlineUnconditionally old_bndr)
+ ; -- pprTrace "postInlineUnconditionally"
+ -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $
+ return (extendIdSubst env old_bndr (DoneEx final_rhs)) }
-- Use the substitution to make quite, quite sure that the
-- substitution will happen, since we are going to discard the binding
+ else
+ do { let info1 = idInfo new_bndr `setArityInfo` new_arity
+
+ -- Unfolding info: Note [Setting the new unfolding]
+ info2 = info1 `setUnfoldingInfo` new_unfolding
+
+ -- Demand info: Note [Setting the demand info]
+ info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
+ | otherwise = info2
+
+ final_id = new_bndr `setIdInfo` info3
- else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) }
+ ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
+ return (addNonRec env final_id final_rhs) } }
+ -- The addNonRec adds it to the in-scope set too
------------------------------
addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv
= do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding
-- Assumes that poly_id did not have an INLINE prag
-- which is perhaps wrong. ToDo: think about this
- ; return (addNonRecWithUnf env poly_id rhs unfolding) }
+ ; let final_id = setIdInfo poly_id $
+ idInfo poly_id `setUnfoldingInfo` unfolding
+ `setArityInfo` exprArity rhs
-addPolyBind _ env bind@(Rec _) = return (extendFloats env bind)
- -- Hack: letrecs are more awkward, so we extend "by steam"
- -- without adding unfoldings etc. At worst this leads to
- -- more simplifier iterations
+ ; return (addNonRec env final_id rhs) }
-------------------------------
-addNonRecWithUnf :: SimplEnv
- -> OutId -> OutExpr -- New binder and RHS
- -> Unfolding -- New unfolding
- -> SimplEnv
-addNonRecWithUnf env new_bndr new_rhs new_unfolding
- = let new_arity = exprArity new_rhs
- old_arity = idArity new_bndr
- info1 = idInfo new_bndr `setArityInfo` new_arity
-
- -- Unfolding info: Note [Setting the new unfolding]
- info2 = info1 `setUnfoldingInfo` new_unfolding
-
- -- Demand info: Note [Setting the demand info]
- info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2
- | otherwise = info2
-
- final_id = new_bndr `setIdInfo` info3
- dmd_arity = length $ fst $ splitStrictSig $ idStrictness new_bndr
- in
- ASSERT( isId new_bndr )
- WARN( new_arity < old_arity || new_arity < dmd_arity,
- (ptext (sLit "Arity decrease:") <+> (ppr final_id <+> ppr old_arity
- <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs) )
- -- Note [Arity decrease]
-
- final_id `seq` -- This seq forces the Id, and hence its IdInfo,
- -- and hence any inner substitutions
- -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
- addNonRec env final_id new_rhs
- -- The addNonRec adds it to the in-scope set too
+addPolyBind _ env bind@(Rec _)
+ = return (extendFloats env bind)
+ -- Hack: letrecs are more awkward, so we extend "by steam"
+ -- without adding unfoldings etc. At worst this leads to
+ -- more simplifier iterations
------------------------------
simplUnfolding :: SimplEnv-> TopLevelFlag
ApplyTo NoDup arg env cont
simplExprF' env expr@(Lam _ _) cont
- = simplLam env (map zap bndrs) body cont
+ = simplLam env zapped_bndrs body cont
-- The main issue here is under-saturated lambdas
-- (\x1. \x2. e) arg1
-- Here x1 might have "occurs-once" occ-info, because occ-info
-- is computed assuming that a group of lambdas is applied
-- all at once. If there are too few args, we must zap the
- -- occ-info.
+ -- occ-info, UNLESS the remaining binders are one-shot
where
- n_args = countArgs cont
- n_params = length bndrs
(bndrs, body) = collectBinders expr
- zap | n_args >= n_params = \b -> b
- | otherwise = \b -> if isTyCoVar b then b
- else zapLamIdInfo b
- -- NB: we count all the args incl type args
- -- so we must count all the binders (incl type lambdas)
+ zapped_bndrs | need_to_zap = map zap bndrs
+ | otherwise = bndrs
+
+ need_to_zap = any zappable_bndr (drop n_args bndrs)
+ n_args = countArgs cont
+ -- NB: countArgs counts all the args (incl type args)
+ -- and likewise drop counts all binders (incl type lambdas)
+
+ zappable_bndr b = isId b && not (isOneShotBndr b)
+ zap b | isTyCoVar b = b
+ | otherwise = zapLamIdInfo b
simplExprF' env (Type ty) cont
= ASSERT( contIsRhsOrArg cont )
rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
-- At this point the substitution in the SimplEnv should be irrelevant
-- only the in-scope set and floats should matter
-rebuild env expr cont0
- = -- pprTrace "rebuild" (ppr expr $$ ppr cont0 $$ ppr (seFloats env)) $
- case cont0 of
+rebuild env expr cont
+ = case cont of
Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCoerce co expr) cont
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont