X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=8ec2d1da57a4b56e70e7c1214f5be2d10745b2ed;hb=b8ee6f14ca6e9e49015ee9b404cf8b8191fede05;hp=62c3c35f34e7adfb726c6f09929b34c94d215bff;hpb=72462499b891d5779c19f3bda03f96e24f9554ae;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 62c3c35..8ec2d1d 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 @@ -31,12 +29,12 @@ import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) +import SimplUtils ( simplEnvForGHCi, simplEnvForRules ) import SimplEnv import SimplMonad import CoreMonad import qualified ErrUtils as Err import CoreLint -import CoreMonad ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv @@ -54,10 +52,6 @@ import Specialise ( specProgram) import SpecConstr ( specConstrProgram) import DmdAnal ( dmdAnalPgm ) import WorkWrap ( wwTopBinds ) -#ifdef OLD_STRICTNESS -import StrictAnal ( saBinds ) -import CprAnalyse ( cprAnalyse ) -#endif import Vectorise ( vectorise ) import FastString import Util @@ -87,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. @@ -99,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 @@ -120,6 +112,8 @@ simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do -> IO CoreExpr -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt +-- +-- Also used by Template Haskell simplifyExpr dflags expr = do { ; Err.showPass dflags "Simplify" @@ -127,7 +121,7 @@ simplifyExpr dflags expr ; us <- mkSplitUniqSupply 's' ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - simplExprGently gentleSimplEnv expr + simplExprGently simplEnvForGHCi expr ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" (pprCoreExpr expr') @@ -135,9 +129,6 @@ simplifyExpr dflags expr ; return expr' } -gentleSimplEnv :: SimplEnv -gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl []) - doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts doCorePasses passes guts = foldM (flip doCorePass) guts passes @@ -190,24 +181,8 @@ doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat -#ifdef OLD_STRICTNESS -doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness -#endif - doCorePass CoreDoNothing = return doCorePass (CoreDoPasses passes) = doCorePasses passes - -#ifdef OLD_STRICTNESS -doOldStrictness :: ModGuts -> CoreM ModGuts -doOldStrictness guts - = do dfs <- getDynFlags - guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $ - doPassM (saBinds dfs) guts - guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $ - doPass cprAnalyse guts' - return guts'' -#endif - \end{code} %************************************************************************ @@ -245,11 +220,10 @@ printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts ruleCheck current_phase pat guts = do - let is_active = isActive current_phase rb <- getRuleBase dflags <- getDynFlags liftIO $ Err.showPass dflags "RuleCheck" - liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts)) + liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts)) return guts @@ -333,7 +307,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) ; let -- Simplify the local rules; boringly, we need to make an in-scope set -- from the local binders, to avoid warnings from Simplify.simplVar local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds)) - env = setInScopeSet gentleSimplEnv local_ids + env = setInScopeSet simplEnvForRules local_ids (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ mapM (simplRule env) local_rules @@ -346,9 +320,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 }) @@ -409,6 +383,7 @@ The simplifier does indeed do eta reduction (it's in Simplify.completeLam) but only if -O is on. \begin{code} +simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule simplRule env rule@(BuiltinRule {}) = return rule simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) @@ -529,7 +504,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base } where dflags = hsc_dflags hsc_env - dump_phase = shouldDumpSimplPhase dflags mode + dump_phase = dumpSimplPhase dflags mode sw_chkr = isAmongSimpl switches max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 @@ -564,6 +539,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 @@ -571,7 +547,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base eps <- hscEPS hsc_env ; let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) ; rule_base2 = extendRuleBaseList rule_base1 rules - ; simpl_env = mkSimplEnv mode sw_chkr + ; simpl_env = mkSimplEnv sw_chkr mode ; simpl_binds = {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ; @@ -592,7 +568,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 @@ -611,7 +587,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - endIteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ; + end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ; -- Loop do_iteration us2 (iteration_no + 1) all_counts binds2 rules1 @@ -620,14 +596,14 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base (us1, us2) = splitUniqSupply us ------------------- -endIteration :: DynFlags -> SimplifierMode -> Int -> Int +end_iteration :: DynFlags -> SimplifierMode -> Int -> Int -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () --- Same as endPass but with simplifier counts -endIteration dflags mode iteration_no max_iterations counts binds rules +-- 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) ; - ; endPass dflags pass_name Opt_D_dump_simpl_iterations binds rules } + ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules } where pass_name = "Simplifier mode " ++ showPpr mode ++ ", iteration " ++ show iteration_no ++ @@ -668,11 +644,11 @@ x_local to transfer to x_exported. Hence the copyIdInfo call. RULES: we want to *add* any RULES for x_local to x_exported. -Note [Messing up the exported Id's IdInfo] +Note [Messing up the exported Id's RULES] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must be careful about discarding the IdInfo on the old Id - -The example that went bad on me at one stage was this one: +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] @@ -843,7 +819,7 @@ transferIdInfo exported_id local_id = modifyIdInfo transfer exported_id where local_info = idInfo local_id - transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info + transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info `setUnfoldingInfo` unfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info `setSpecInfo` addSpecInfo (specInfo exp_info) new_info