From f95a95425727fd0086df26f7d47f79c911e04b34 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 27 Oct 2010 19:37:29 +0000 Subject: [PATCH] Two signficant changes to the simplifier 1. Do eta-expansion at let-bindings, not lambdas. I have wanted to do this for a long time. See Note [Eta-expanding at let bindings] in SimplUtils 2. Simplify the rather subtle way in which InlineRules (the template captured by an INLINE pragma) was simplified. Now, these templates are always simplified in "gentle" mode only, and only INLINE things inline inside them. See Note Note [Gentle mode], Note [Inlining in gentle mode] and Note [RULEs enabled in SimplGently] in SimplUtils --- compiler/basicTypes/BasicTypes.lhs | 19 +- compiler/simplCore/SimplEnv.lhs | 4 +- compiler/simplCore/SimplUtils.lhs | 432 ++++++++++++++++++++---------------- compiler/simplCore/Simplify.lhs | 114 +++++----- 4 files changed, 310 insertions(+), 259 deletions(-) diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index ce47e58..499d7be 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -65,7 +65,8 @@ module BasicTypes( InlineSpec(..), InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma, - isDefaultInlinePragma, isInlinePragma, isInlinablePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isAnyInlinePragma, inlinePragmaSpec, inlinePragmaSat, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, @@ -736,11 +737,6 @@ isFunLike :: RuleMatchInfo -> Bool isFunLike FunLike = True isFunLike _ = False -isInlineSpec :: InlineSpec -> Bool -isInlineSpec Inline = True -isInlineSpec Inlinable = True -isInlineSpec _ = False - isEmptyInlineSpec :: InlineSpec -> Bool isEmptyInlineSpec EmptyInlineSpec = True isEmptyInlineSpec _ = False @@ -772,13 +768,22 @@ isDefaultInlinePragma (InlinePragma { inl_act = activation = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info isInlinePragma :: InlinePragma -> Bool -isInlinePragma prag = isInlineSpec (inl_inline prag) +isInlinePragma prag = case inl_inline prag of + Inline -> True + _ -> False isInlinablePragma :: InlinePragma -> Bool isInlinablePragma prag = case inl_inline prag of Inlinable -> True _ -> False +isAnyInlinePragma :: InlinePragma -> Bool +-- INLINE or INLINABLE +isAnyInlinePragma prag = case inl_inline prag of + Inline -> True + Inlinable -> True + _ -> False + inlinePragmaSat :: InlinePragma -> Maybe Arity inlinePragmaSat = inl_sat diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index b7b4444..865acdc 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -403,7 +403,9 @@ addNonRec :: SimplEnv -> OutId -> OutExpr -> SimplEnv -- in-scope set (although it might also have been created with newId) -- but it may now have more IdInfo addNonRec env id rhs - = env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), + = id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + env { seFloats = seFloats env `addFlts` unitFloat (NonRec id rhs), seInScope = extendInScopeSet (seInScope env) id } extendFloats :: SimplEnv -> OutBind -> SimplEnv diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 1fb04fe..1618525 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -6,7 +6,7 @@ \begin{code} module SimplUtils ( -- Rebuilding - mkLam, mkCase, prepareAlts, + mkLam, mkCase, prepareAlts, tryEtaExpand, -- Inlining, preInlineUnconditionally, postInlineUnconditionally, @@ -41,7 +41,7 @@ import CoreArity import CoreUnfold import Name import Id -import Var ( Var, isCoVar ) +import Var import Demand import SimplMonad import Type hiding( substTy ) @@ -452,10 +452,9 @@ interestingArgContext rules call_cont \end{code} - %************************************************************************ %* * -\subsection{Decisions about inlining} + Gentle mode %* * %************************************************************************ @@ -476,9 +475,33 @@ Gentle mode has a separate boolean flag to control 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 = ... @@ -524,6 +547,9 @@ RULES are enabled when doing "gentle" simplification. Two reasons: 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 @@ -543,57 +569,7 @@ one; see OccurAnal.addRuleUsage. 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 f #-} - f = -meaning "inline f in phases p where activation (p) holds". -Then what inlinings/rules can we apply to the copy of captured in -f's InlineRule? Our model is that literally 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 ~~~~~~~~~~~~~~~~~~~~~ @@ -607,41 +583,155 @@ mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf 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 f #-} + f = + meaning "inline f in phases p where activation (p) holds". + Then what inlinings/rules can we apply to the copy of captured in + f's InlineRule? Our model is that literally 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 ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -814,6 +904,12 @@ preInlineUnconditionally env top_lvl bndr rhs \end{code} +%************************************************************************ +%* * + postInlineUnconditionally +%* * +%************************************************************************ + postInlineUnconditionally ~~~~~~~~~~~~~~~~~~~~~~~~~ @postInlineUnconditionally@ decides whether to unconditionally inline @@ -923,69 +1019,6 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding -- 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] @@ -1057,40 +1090,10 @@ mkLam _env bndrs body = 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] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1124,20 +1127,65 @@ It does not make sense to transform /\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! + %************************************************************************ %* * diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 179af4f..8d314ae 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -26,14 +26,14 @@ import FamInstEnv ( topNormaliseType ) 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 ) @@ -629,21 +629,41 @@ completeBind :: SimplEnv -- * 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 @@ -662,44 +682,17 @@ addPolyBind top_lvl env (NonRec poly_id rhs) = 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 @@ -882,22 +875,26 @@ simplExprF' env (App fun arg) cont = simplExprF env fun $ 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 ) @@ -957,9 +954,8 @@ simplCoercion env co 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 -- 1.7.10.4