X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=4df489b99ca68ed60dcea471cd338b02e49e9a61;hp=5dfd40b144520de90d80c7e969aac79597fe6c82;hb=d4f4391a030e683572eee01291cc8bc6203dbf5d;hpb=c86161c5cf11de77e911fcb9e1e2bd1f8bd80b42 diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 5dfd40b..4df489b 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -15,9 +15,7 @@ module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" -import DynFlags ( CoreToDo(..), SimplifierSwitch(..), - SimplifierMode(..), DynFlags, DynFlag(..), dopt, - getCoreToDo, shouldDumpSimplPhase ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn import CoreSubst import HscTypes @@ -37,7 +35,6 @@ import SimplMonad import CoreMonad import qualified ErrUtils as Err import CoreLint -import CoreMonad ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv @@ -84,10 +81,8 @@ core2core hsc_env guts = do us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us - -- COMPUTE THE ANNOTATIONS TO USE - ann_env <- prepareAnnotations hsc_env (Just guts) - -- COMPUTE THE RULE BASE TO USE + -- See Note [Overall plumbing for rules] in Rules.lhs (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us -- Get the module out of the current HscEnv so we can retrieve it from the monad. @@ -96,7 +91,7 @@ core2core hsc_env guts = do -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. let mod = mg_module guts - (guts2, stats) <- runCoreM hsc_env ann_env hpt_rule_base cp_us mod $ do + (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do -- FIND BUILT-IN PASSES let builtin_core_todos = getCoreToDo dflags @@ -135,57 +130,55 @@ simplifyExpr dflags expr } doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts -doCorePasses passes guts = foldM (flip doCorePass) guts passes +doCorePasses passes guts + = foldM do_pass guts passes + where + do_pass guts CoreDoNothing = return guts + do_pass guts (CoreDoPasses ps) = doCorePasses ps guts + do_pass guts pass + = do { dflags <- getDynFlags + ; liftIO $ showPass dflags pass + ; guts' <- doCorePass pass guts + ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') + ; return guts' } doCorePass :: CorePass -> ModGuts -> CoreM ModGuts -doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-} - simplifyPgm mode sws +doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} + simplifyPgm pass doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - describePass "Common sub-expression" Opt_D_dump_cse $ doPass cseProgram doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} - describePass "Liberate case" Opt_D_verbose_core2core $ doPassD liberateCase doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - describePass "Float inwards" Opt_D_verbose_core2core $ doPass floatInwards doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} - describePassD (text "Float out" <+> parens (ppr f)) - Opt_D_verbose_core2core $ doPassDUM (floatOutwards f) doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} - describePass "Static argument" Opt_D_verbose_core2core $ doPassU doStaticArgs doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} - describePass "Demand analysis" Opt_D_dump_stranal $ doPassDM dmdAnalPgm doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} - describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $ doPassU wwTopBinds doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - describePassR "Specialise" Opt_D_dump_spec $ doPassU specProgram doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} - describePassR "SpecConstr" Opt_D_dump_spec $ specConstrProgram doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} - describePass "Vectorisation" Opt_D_dump_vect $ vectorise be -doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds -doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore -doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat - +doCorePass CoreDoGlomBinds = doPassDM glomBinds +doCorePass CoreDoPrintCore = observe printCore +doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat doCorePass CoreDoNothing = return doCorePass (CoreDoPasses passes) = doCorePasses passes \end{code} @@ -197,30 +190,6 @@ doCorePass (CoreDoPasses passes) = doCorePasses passes %************************************************************************ \begin{code} - -dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -dontDescribePass = ($) - -describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -describePass name dflag pass guts = do - dflags <- getDynFlags - - liftIO $ Err.showPass dflags name - guts' <- pass guts - liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts') - - return guts' - -describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -describePassD doc = describePass (showSDoc doc) - -describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts -describePassR name dflag pass guts = do - guts' <- describePass name dflag pass guts - dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations" - (pprRulesForUser (rulesOfBinds (mg_binds guts'))) - return guts' - printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts @@ -325,9 +294,9 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $ - vcat [text "Local rules", pprRules simpl_rules, + vcat [text "Local rules for local Ids", pprRules simpl_rules, blankLine, - text "Imported rules", pprRuleBase hpt_rule_base]) + text "Local rules for imported Ids", pprRuleBase hpt_rule_base]) ; return (hpt_rule_base, guts { mg_binds = binds_w_rules, mg_rules = rules_for_imps }) @@ -473,26 +442,23 @@ glomBinds dflags binds %************************************************************************ \begin{code} -simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts -simplifyPgm mode switches - = describePassD doc Opt_D_dump_simpl_phases $ \guts -> - do { hsc_env <- getHscEnv +simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts +simplifyPgm pass guts + = do { hsc_env <- getHscEnv ; us <- getUniqueSupplyM ; rb <- getRuleBase ; liftIOWithCount $ - simplifyPgmIO mode switches hsc_env us rb guts } - where - doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) + simplifyPgmIO pass hsc_env us rb guts } -simplifyPgmIO :: SimplifierMode - -> [SimplifierSwitch] +simplifyPgmIO :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts) -- New bindings -simplifyPgmIO mode switches hsc_env us hpt_rule_base +simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches) + hsc_env us hpt_rule_base guts@(ModGuts { mg_binds = binds, mg_rules = rules , mg_fam_inst_env = fam_inst_env }) = do { @@ -509,11 +475,8 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base } where dflags = hsc_dflags hsc_env - dump_phase = shouldDumpSimplPhase dflags mode - - sw_chkr = isAmongSimpl switches - max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 - + dump_phase = dumpSimplPhase dflags mode + sw_chkr = isAmongSimpl switches do_iteration :: UniqSupply -> Int -- Counts iterations -> SimplCount -- Logs optimisations performed @@ -544,6 +507,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base (pprCoreBindings tagged_binds); -- Get any new rules, and extend the rule base + -- See Note [Overall plumbing for rules] in Rules.lhs -- We need to do this 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 @@ -572,7 +536,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base let { all_counts = counts `plusSimplCount` counts1 ; binds1 = getFloats env1 - ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules + ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules } ; -- Stop if nothing happened; don't dump output @@ -591,7 +555,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ; + end_iteration dflags pass iteration_no counts1 binds2 rules1 ; -- Loop do_iteration us2 (iteration_no + 1) all_counts binds2 rules1 @@ -600,18 +564,15 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base (us1, us2) = splitUniqSupply us ------------------- -end_iteration :: DynFlags -> SimplifierMode -> Int -> Int +end_iteration :: DynFlags -> CoreToDo -> Int -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () -- Same as endIteration but with simplifier counts -end_iteration dflags mode iteration_no max_iterations counts binds rules - = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name - (pprSimplCount counts) ; +end_iteration dflags pass iteration_no counts binds rules + = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags) + pass (ptext (sLit "Simplifier counts")) + (pprSimplCount counts) - ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules } - where - pass_name = "Simplifier mode " ++ showPpr mode ++ - ", iteration " ++ show iteration_no ++ - " out of " ++ show max_iterations + ; endIteration dflags pass iteration_no binds rules } \end{code}