diff options
Diffstat (limited to 'compiler/GHC/Core/Opt')
| -rw-r--r-- | compiler/GHC/Core/Opt/Monad.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Pipeline.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 14 |
3 files changed, 26 insertions, 22 deletions
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 6f520cfcfd..d38f3e6c59 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -21,7 +21,7 @@ module GHC.Core.Opt.Monad ( getDynFlags, getPackageFamInstEnv, getInteractiveContext, getUniqMask, - getPrintUnqualified, getSrcSpanM, + getNamePprCtx, getSrcSpanM, -- ** Writing to the monad addSimplCount, @@ -114,7 +114,7 @@ data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, -- Home package table rules cr_module :: Module, - cr_print_unqual :: PrintUnqualified, + cr_name_ppr_ctx :: NamePprCtx, cr_loc :: SrcSpan, -- Use this for log/error messages so they -- are at least tagged with the right source file cr_uniq_mask :: !Char -- Mask for creating unique values @@ -178,18 +178,18 @@ runCoreM :: HscEnv -> RuleBase -> Char -- ^ Mask -> Module - -> PrintUnqualified + -> NamePprCtx -> SrcSpan -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base mask mod print_unqual loc m +runCoreM hsc_env rule_base mask mod name_ppr_ctx loc m = liftM extract $ runIOEnv reader $ unCoreM m where reader = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, cr_module = mod, - cr_print_unqual = print_unqual, + cr_name_ppr_ctx = name_ppr_ctx, cr_loc = loc, cr_uniq_mask = mask } @@ -252,8 +252,8 @@ initRuleEnv guts getExternalRuleBase :: CoreM RuleBase getExternalRuleBase = eps_rule_base <$> get_eps -getPrintUnqualified :: CoreM PrintUnqualified -getPrintUnqualified = read cr_print_unqual +getNamePprCtx :: CoreM NamePprCtx +getNamePprCtx = read cr_name_ppr_ctx getSrcSpanM :: CoreM SrcSpan getSrcSpanM = read cr_loc @@ -360,14 +360,14 @@ msg :: MessageClass -> SDoc -> CoreM () msg msg_class doc = do logger <- getLogger loc <- getSrcSpanM - unqual <- getPrintUnqualified + name_ppr_ctx <- getNamePprCtx let sty = case msg_class of MCDiagnostic _ _ _ -> err_sty MCDump -> dump_sty _ -> user_sty - err_sty = mkErrStyle unqual - user_sty = mkUserStyle unqual AllTheWay - dump_sty = mkDumpStyle unqual + err_sty = mkErrStyle name_ppr_ctx + user_sty = mkUserStyle name_ppr_ctx AllTheWay + dump_sty = mkDumpStyle name_ppr_ctx liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) -- | Output a String message to the screen diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index c7834a0b31..8be830dbeb 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -81,7 +81,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod uniq_mask = 's' ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod - print_unqual loc $ + name_ppr_ctx loc $ do { hsc_env' <- getHscEnv ; all_passes <- withPlugins (hsc_plugins hsc_env') installCoreToDos @@ -101,7 +101,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules - print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env + name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to -- consume the ModGuts to find the module) but somewhat ugly because mg_module may @@ -488,10 +489,15 @@ doCorePass pass guts = do let fam_envs = (p_fam_env, mg_fam_inst_env guts) let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } + let name_ppr_ctx = + mkNamePprCtx + (initPromotionTickContext dflags) + (hsc_unit_env hsc_env) + (mg_rdr_env guts) case pass of CoreDoSimplify opts -> {-# SCC "Simplify" #-} - liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) opts guts + liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts CoreCSE -> {-# SCC "CommonSubExpr" #-} updateBinds cseProgram diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 0c8ec92f6c..0cc6d984e5 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -39,7 +39,6 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish import GHC.Types.Unique.FM -import GHC.Types.Name.Ppr import Control.Monad import Data.Foldable ( for_ ) @@ -140,13 +139,13 @@ data SimplifyOpts = SimplifyOpts simplifyPgm :: Logger -> UnitEnv + -> NamePprCtx -- For dumping -> SimplifyOpts -> ModGuts -> IO (SimplCount, ModGuts) -- New bindings -simplifyPgm logger unit_env opts +simplifyPgm logger unit_env name_ppr_ctx opts guts@(ModGuts { mg_module = this_mod - , mg_rdr_env = rdr_env , mg_binds = binds, mg_rules = local_rules , mg_fam_inst_env = fam_inst_env }) = do { (termination_msg, it_count, counts_out, guts') @@ -168,7 +167,6 @@ simplifyPgm logger unit_env opts mode = so_mode opts max_iterations = so_iterations opts top_env_cfg = so_top_env_cfg opts - print_unqual = mkPrintUnqualified unit_env rdr_env active_rule = activeRule mode active_unf = activeUnfolding mode -- Note the bang in !guts_no_binds. If you don't force `guts_no_binds` @@ -275,7 +273,7 @@ simplifyPgm logger unit_env opts let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ; + 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 ; @@ -292,10 +290,10 @@ simplifyPgm logger unit_env opts totalise = foldr (\c acc -> acc `plusSimplCount` c) (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) -dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int +dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules - = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules +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 |