{-# LANGUAGE CPP #-} module GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) , simplifyExpr, simplifyPgm ) where import GHC.Prelude import GHC.Driver.Flags import GHC.Core import GHC.Core.Rules import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize ) import GHC.Core.Utils ( mkTicks, stripTicksTop ) import GHC.Core.Lint ( LintPassResultConfig, dumpPassResult, lintPassResult ) import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) import GHC.Core.Opt.Simplify.Utils ( activeRule, activeUnfolding ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Stats ( simplCountN ) import GHC.Core.FamInstEnv import GHC.Utils.Error ( withTiming ) import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Constants (debugIsOn) import GHC.Unit.Env ( UnitEnv, ueEPS ) import GHC.Unit.External import GHC.Unit.Module.ModGuts import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish import GHC.Types.Unique.FM import Control.Monad import Data.Foldable ( for_ ) #if __GLASGOW_HASKELL__ <= 810 import GHC.Utils.Panic ( panic ) #endif {- ************************************************************************ * * Gentle simplification * * ************************************************************************ -} -- | Configuration record for `simplifyExpr`. -- The values of this datatype are /only/ driven by the demands of that function. data SimplifyExprOpts = SimplifyExprOpts { se_fam_inst :: ![FamInst] , se_mode :: !SimplMode , se_top_env_cfg :: !TopEnvConfig } simplifyExpr :: Logger -> ExternalUnitCache -> SimplifyExprOpts -> CoreExpr -> IO CoreExpr -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt simplifyExpr logger euc opts expr = withTiming logger (text "Simplify [expr]") (const ()) $ do { eps <- eucEPS euc ; ; let fam_envs = ( eps_fam_inst_env eps , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts ) simpl_env = mkSimplEnv (se_mode opts) fam_envs top_env_cfg = se_top_env_cfg opts read_eps_rules = eps_rule_base <$> eucEPS euc read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules ; let sz = exprSize expr ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $ simplExprGently simpl_env expr ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats "Simplifier statistics" FormatText (pprSimplCount counts) ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression" FormatCore (pprCoreExpr expr') ; return expr' } simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- Simplifies an expression -- does occurrence analysis, then simplification -- and repeats (twice currently) because one pass -- alone leaves tons of crud. -- Used (a) for user expressions typed in at the interactive prompt -- (b) the LHS and RHS of a RULE -- (c) Template Haskell splices -- -- The name 'Gently' suggests that the SimplMode is InitialPhase, -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't -- enforce that; it just simplifies the expression twice -- It's important that simplExprGently does eta reduction; see -- Note [Simplify rule LHS] above. The -- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam) -- but only if -O is on. simplExprGently env expr = do expr1 <- simplExpr env (occurAnalyseExpr expr) simplExpr env (occurAnalyseExpr expr1) {- ************************************************************************ * * \subsection{The driver for the simplifier} * * ************************************************************************ -} -- | Configuration record for `simplifyPgm`. -- The values of this datatype are /only/ driven by the demands of that function. data SimplifyOpts = SimplifyOpts { so_dump_core_sizes :: !Bool , so_iterations :: !Int , so_mode :: !SimplMode , so_pass_result_cfg :: !(Maybe LintPassResultConfig) -- Nothing => Do not Lint -- Just cfg => Lint like this , so_hpt_rules :: !RuleBase , so_top_env_cfg :: !TopEnvConfig } simplifyPgm :: Logger -> UnitEnv -> NamePprCtx -- For dumping -> SimplifyOpts -> ModGuts -> IO (SimplCount, ModGuts) -- New bindings simplifyPgm logger unit_env name_ppr_ctx opts guts@(ModGuts { mg_module = this_mod , mg_binds = binds, mg_rules = local_rules , mg_fam_inst_env = fam_inst_env }) = do { (termination_msg, it_count, counts_out, guts') <- do_iteration 1 [] binds local_rules ; when (logHasDumpFlag logger Opt_D_verbose_core2core && logHasDumpFlag logger Opt_D_dump_simpl_stats) $ logDumpMsg logger "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", blankLine, pprSimplCount counts_out]) ; return (counts_out, guts') } where dump_core_sizes = so_dump_core_sizes opts mode = so_mode opts max_iterations = so_iterations opts top_env_cfg = so_top_env_cfg opts active_rule = activeRule mode active_unf = activeUnfolding mode -- Note the bang in !guts_no_binds. If you don't force `guts_no_binds` -- the old bindings are retained until the end of all simplifier iterations !guts_no_binds = guts { mg_binds = [], mg_rules = [] } hpt_rule_env :: RuleEnv hpt_rule_env = mkRuleEnv guts emptyRuleBase (so_hpt_rules opts) -- emptyRuleBase: no EPS rules yet; we will update -- them on each iteration to pick up the most up to date set do_iteration :: Int -- Counts iterations -> [SimplCount] -- Counts from earlier iterations, reversed -> CoreProgram -- Bindings -> [CoreRule] -- Local rules for imported Ids -> IO (String, Int, SimplCount, ModGuts) do_iteration iteration_no counts_so_far binds local_rules -- iteration_no is the number of the iteration we are -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations = warnPprTrace (debugIsOn && (max_iterations > 2)) "Simplifier bailing out" ( hang (ppr this_mod <> text ", after" <+> int max_iterations <+> text "iterations" <+> (brackets $ hsep $ punctuate comma $ map (int . simplCountN) (reverse counts_so_far))) 2 (text "Size =" <+> ppr (coreBindsStats binds))) $ -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed return ( "Simplifier baled out", iteration_no - 1 , totalise counts_so_far , guts_no_binds { mg_binds = binds, mg_rules = local_rules } ) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. | let sz = coreBindsSize binds , () <- sz `seq` () -- Force it = do { -- Occurrence analysis let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm this_mod active_unf active_rule local_rules binds } ; Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings tagged_binds); -- read_eps_rules: -- We need to read rules from the EPS regularly because simplification can -- poke on IdInfo thunks, which in turn brings in new rules -- behind the scenes. Otherwise there's a danger we'll simply -- miss the rules for Ids hidden inside imported inlinings -- Hence just before attempting to match a rule we read the EPS -- value (via read_rule_env) and then combine it with the existing rule base. -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`. eps <- ueEPS unit_env ; let { -- base_rule_env contains -- (a) home package rules, fixed across all iterations -- (b) local rules (substituted) from `local_rules` arg to do_iteration -- Forcing base_rule_env to avoid unnecessary allocations. -- Not doing so results in +25.6% allocations of LargeRecord. ; !base_rule_env = updLocalRules hpt_rule_env local_rules ; read_eps_rules :: IO PackageRuleBase ; read_eps_rules = eps_rule_base <$> ueEPS unit_env ; read_rule_env :: IO RuleEnv ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) ; simpl_env = mkSimplEnv mode fam_envs } ; -- Simplify the program ((binds1, rules1), counts1) <- initSmpl logger read_rule_env top_env_cfg sz $ do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds -- Apply the substitution to rules defined in this module -- for imported Ids. Eg RULE map my_f = blah -- If we have a substitution my_f :-> other_f, we'd better -- apply it to the rule to, or it'll never match ; rules1 <- simplImpRules env1 local_rules ; return (getTopFloatBinds floats, rules1) } ; -- Stop if nothing happened; don't dump output -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats if isZeroSimplCount counts1 then return ( "Simplifier reached fixed point", iteration_no , totalise (counts1 : counts_so_far) -- Include "free" ticks , guts_no_binds { mg_binds = binds1, mg_rules = rules1 } ) else do { -- Short out indirections -- We do this *after* at least one run of the simplifier -- because indirection-shorting uses the export flag on *occurrences* -- and that isn't guaranteed to be ok until after the first run propagates -- stuff from the binding site to its occurrences -- -- ToDo: alas, this means that indirection-shorting does not happen at all -- if the simplifier does nothing (not common, I know, but unsavoury) let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 binds2 rules1 ; for_ (so_pass_result_cfg opts) $ \pass_result_cfg -> lintPassResult logger pass_result_cfg binds2 ; -- Loop do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 } } #if __GLASGOW_HASKELL__ <= 810 | otherwise = panic "do_iteration" #endif where -- Remember the counts_so_far are reversed totalise :: [SimplCount] -> SimplCount totalise = foldr (\c acc -> acc `plusSimplCount` c) (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules = dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr pp_counts binds rules where mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations | otherwise = Nothing -- Show details if Opt_D_dump_simpl_iterations is on hdr = "Simplifier iteration=" ++ show iteration_no pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr , pprSimplCount counts , text "---- End of simplifier counts for" <+> text hdr ] {- ************************************************************************ * * Shorting out indirections * * ************************************************************************ If we have this: x_local = ...bindings... x_exported = x_local where x_exported is exported, and x_local is not, then we replace it with this: x_exported = x_local = x_exported ...bindings... Without this we never get rid of the x_exported = x_local thing. This save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and makes strictness information propagate better. This used to happen in the final phase, but it's tidier to do it here. Note [Messing up the exported Id's RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must be careful about discarding (obviously) or even merging the RULES on the exported Id. The example that went bad on me at one stage was this one: iterate :: (a -> a) -> a -> [a] [Exported] iterate = iterateList iterateFB c f x = x `c` iterateFB c f (f x) iterateList f x = x : iterateList f (f x) [Not exported] {-# RULES "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) "iterateFB" iterateFB (:) = iterateList #-} This got shorted out to: iterateList :: (a -> a) -> a -> [a] iterateList = iterate iterateFB c f x = x `c` iterateFB c f (f x) iterate f x = x : iterate f (f x) {-# RULES "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) "iterateFB" iterateFB (:) = iterate #-} And now we get an infinite loop in the rule system iterate f x -> build (\cn -> iterateFB c f x) -> iterateFB (:) f x -> iterate f x Old "solution": use rule switching-off pragmas to get rid of iterateList in the first place But in principle the user *might* want rules that only apply to the Id they say. And inline pragmas are similar {-# NOINLINE f #-} f = local local = Then we do not want to get rid of the NOINLINE. Hence hasShortableIdinfo. Note [Rules and indirection-zapping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Problem: what if x_exported has a RULE that mentions something in ...bindings...? Then the things mentioned can be out of scope! Solution a) Make sure that in this pass the usage-info from x_exported is available for ...bindings... b) If there are any such RULES, rec-ify the entire top-level. It'll get sorted out next time round Other remarks ~~~~~~~~~~~~~ If more than one exported thing is equal to a local thing (i.e., the local thing really is shared), then we do one only: \begin{verbatim} x_local = .... x_exported1 = x_local x_exported2 = x_local ==> x_exported1 = .... x_exported2 = x_exported1 \end{verbatim} We rely on prior eta reduction to simplify things like \begin{verbatim} x_exported = /\ tyvars -> x_local tyvars ==> x_exported = x_local \end{verbatim} Hence,there's a possibility of leaving unchanged something like this: \begin{verbatim} x_local = .... x_exported1 = x_local Int \end{verbatim} By the time we've thrown away the types in STG land this could be eliminated. But I don't think it's very common and it's dangerous to do this fiddling in STG land because we might eliminate a binding that's mentioned in the unfolding for something. Note [Indirection zapping and ticks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unfortunately this is another place where we need a special case for ticks. The following happens quite regularly: x_local = x_exported = tick x_local Which we want to become: x_exported = tick As it makes no sense to keep the tick and the expression on separate bindings. Note however that this might increase the ticks scoping over the execution of x_local, so we can only do this for floatable ticks. More often than not, other references will be unfoldings of x_exported, and therefore carry the tick anyway. -} type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds | isEmptyVarEnv ind_env = binds | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping] | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff where ind_env = makeIndEnv binds -- These exported Ids are the subjects of the indirection-elimination exp_ids = map fst $ nonDetEltsUFM ind_env -- It's OK to use nonDetEltsUFM here because we forget the ordering -- by immediately converting to a set or check if all the elements -- satisfy a predicate. exp_id_set = mkVarSet exp_ids no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids binds' = concatMap zap binds zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] zap (Rec pairs) = [Rec (concatMap zapPair pairs)] zapPair (bndr, rhs) | bndr `elemVarSet` exp_id_set = [] -- Kill the exported-id binding | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr , (exp_id', lcl_id') <- transferIdInfo exp_id bndr = -- Turn a local-id binding into two bindings -- exp_id = rhs; lcl_id = exp_id [ (exp_id', mkTicks ticks rhs), (lcl_id', Var exp_id') ] | otherwise = [(bndr,rhs)] makeIndEnv :: [CoreBind] -> IndEnv makeIndEnv binds = foldl' add_bind emptyVarEnv binds where add_bind :: IndEnv -> CoreBind -> IndEnv add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs) add_bind env (Rec pairs) = foldl' add_pair env pairs add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv add_pair env (exported_id, exported) | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported , shortMeOut env exported_id local_id = extendVarEnv env local_id (exported_id, ticks) add_pair env _ = env shortMeOut :: IndEnv -> Id -> Id -> Bool shortMeOut ind_env exported_id local_id -- The if-then-else stuff is just so I can get a pprTrace to see -- how often I don't get shorting out because of IdInfo stuff = if isExportedId exported_id && -- Only if this is exported isLocalId local_id && -- Only if this one is defined in this -- module, so that we *can* change its -- binding to be the exported thing! not (isExportedId local_id) && -- Only if this one is not itself exported, -- since the transformation will nuke it not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for then if hasShortableIdInfo exported_id then True -- See Note [Messing up the exported Id's RULES] else warnPprTrace True "Not shorting out" (ppr exported_id) False else False hasShortableIdInfo :: Id -> Bool -- True if there is no user-attached IdInfo on exported_id, -- so we can safely discard it -- See Note [Messing up the exported Id's RULES] hasShortableIdInfo id = isEmptyRuleInfo (ruleInfo info) && isDefaultInlinePragma (inlinePragInfo info) && not (isStableUnfolding (realUnfoldingInfo info)) where info = idInfo id {- Note [Transferring IdInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have lcl_id = e; exp_id = lcl_id and lcl_id has useful IdInfo, we don't want to discard it by going gbl_id = e; lcl_id = gbl_id Instead, transfer IdInfo from lcl_id to exp_id, specifically * (Stable) unfolding * Strictness * Rules * Inline pragma Overwriting, rather than merging, seems to work ok. For the lcl_id we * Zap the InlinePragma. It might originally have had a NOINLINE, which we have now transferred; and we really want the lcl_id to inline now that its RHS is trivial! * Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline, replacing lcl_id by gbl_id. That won't happen if lcl_id has its original great big Stable unfolding -} transferIdInfo :: Id -> Id -> (Id, Id) -- See Note [Transferring IdInfo] transferIdInfo exported_id local_id = ( modifyIdInfo transfer exported_id , modifyIdInfo zap_info local_id ) where local_info = idInfo local_id transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info `setCprSigInfo` cprSigInfo local_info `setUnfoldingInfo` realUnfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info new_info = setRuleInfoHead (idName exported_id) (ruleInfo local_info) -- Remember to set the function-name field of the -- rules as we transfer them from one function to another zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma `setUnfoldingInfo` noUnfolding