X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplUtils.lhs;h=16185250c86e8ec579833a5c461d9865bf70dd6a;hb=9ba922ee06b048774d7a82964867ff768a78126e;hp=a37cfe987057cc29711b219f0bd08a3231723090;hpb=a06cc26192b0df5726e7ae201e94379c734423fc;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index a37cfe9..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, @@ -15,8 +15,9 @@ module SimplUtils ( -- 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, @@ -40,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 ) @@ -99,12 +100,12 @@ data SimplCont 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 @@ -151,14 +152,31 @@ instance Outputable SimplCont where (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 @@ -179,8 +197,8 @@ contIsRhsOrArg _ = False ------------------- 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 @@ -238,9 +256,10 @@ contArgs cont@(ApplyTo {}) 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 @@ -433,10 +452,9 @@ interestingArgContext rules call_cont \end{code} - %************************************************************************ %* * -\subsection{Decisions about inlining} + Gentle mode %* * %************************************************************************ @@ -457,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 = ... @@ -505,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 @@ -524,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 ~~~~~~~~~~~~~~~~~~~~~ @@ -588,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 ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -795,6 +904,12 @@ preInlineUnconditionally env top_lvl bndr rhs \end{code} +%************************************************************************ +%* * + postInlineUnconditionally +%* * +%************************************************************************ + postInlineUnconditionally ~~~~~~~~~~~~~~~~~~~~~~~~~ @postInlineUnconditionally@ decides whether to unconditionally inline @@ -904,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] @@ -1038,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] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1105,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! + %************************************************************************ %* *