X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=23a2472b23c8bf12fa7aeeb670398203c4786af5;hp=5b52d2d2d72eb7bd79a741ec732d81f7e554fae2;hb=a1fae73a83665d7b9134509e80d34ff69a009cc7;hpb=9bcaaaaa59acff95886ad3675677e58c43106bd2 diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 5b52d2d..23a2472 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -4,67 +4,47 @@ \section[SimplCore]{Driver for simplifying @Core@ programs} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - 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 import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, - extendRuleBaseList, pprRuleBase, ruleCheckProgram, - addSpecInfo, addIdSpecialisations ) -import PprCore ( pprCoreBindings, pprCoreExpr, pprRules ) + extendRuleBaseList, ruleCheckProgram, addSpecInfo, ) +import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) -import IdInfo ( setNewStrictnessInfo, newStrictnessInfo, - setWorkerInfo, workerInfo, setSpecInfoHead, - setInlinePragInfo, inlinePragInfo, - setSpecInfo, specInfo, specInfoRules ) +import IdInfo import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) -import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet ) +import SimplUtils ( simplEnvForGHCi, activeRule ) +import SimplEnv import SimplMonad -import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) -import CoreLint ( endPassIf, endIteration ) +import CoreMonad +import qualified ErrUtils as Err import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv import Id -import DataCon -import TyCon ( tyConSelIds, tyConDataCons ) -import Class ( classSelIds ) +import BasicTypes ( CompilerPhase, isDefaultInlinePragma ) import VarSet import VarEnv -import NameEnv ( lookupNameEnv ) import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) 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 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) -import IO ( hPutStr, stderr ) import Outputable import Control.Monad -import List ( partition, intersperse ) -import Maybes \end{code} %************************************************************************ @@ -74,309 +54,171 @@ import Maybes %************************************************************************ \begin{code} -core2core :: HscEnv - -> ModGuts - -> IO ModGuts +core2core :: HscEnv -> ModGuts -> IO ModGuts +core2core hsc_env guts + = do { us <- mkSplitUniqSupply 's' + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ + doCorePasses (getCoreToDo dflags) guts -core2core hsc_env guts - = do { - ; let dflags = hsc_dflags hsc_env - core_todos = getCoreToDo dflags + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats + "Grand total simplifier statistics" + (pprSimplCount stats) - ; us <- mkSplitUniqSupply 's' - ; let (cp_us, ru_us) = splitUniqSupply us + ; return guts2 } + where + dflags = hsc_dflags hsc_env + home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts)) + hpt_rule_base = mkRuleBase home_pkg_rules + mod = mg_module guts + -- 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 + -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which + -- would mean our cached value would go out of date. + + +type CorePass = CoreToDo + +doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts +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' } - -- COMPUTE THE RULE BASE TO USE - ; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us +doCorePass :: CorePass -> ModGuts -> CoreM ModGuts +doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} + simplifyPgm pass - -- Note [Injecting implicit bindings] - ; let implicit_binds = getImplicitBinds (mg_types guts1) - guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 } +doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} + doPass cseProgram - -- DO THE BUSINESS - ; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us - (zeroSimplCount dflags) - guts2 core_todos +doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} + doPassD liberateCase - ; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats - "Grand total simplifier statistics" - (pprSimplCount stats) +doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} + doPass floatInwards - ; return guts3 } +doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} + doPassDUM (floatOutwards f) +doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} + doPassU doStaticArgs -simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do - -> CoreExpr - -> IO CoreExpr --- simplifyExpr is called by the driver to simplify an --- expression typed in at the interactive prompt -simplifyExpr dflags expr - = do { - ; showPass dflags "Simplify" +doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} + doPassDM dmdAnalPgm - ; us <- mkSplitUniqSupply 's' +doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} + doPassU wwTopBinds - ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - simplExprGently gentleSimplEnv expr +doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} + specProgram - ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" - (pprCoreExpr expr') +doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} + specConstrProgram - ; return expr' - } +doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} + vectorise -gentleSimplEnv :: SimplEnv -gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl []) - -doCorePasses :: HscEnv - -> RuleBase -- the imported main rule base - -> UniqSupply -- uniques - -> SimplCount -- simplifier stats - -> ModGuts -- local binds in (with rules attached) - -> [CoreToDo] -- which passes to do - -> IO (SimplCount, ModGuts) - -doCorePasses hsc_env rb us stats guts [] - = return (stats, guts) - -doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2) - = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2) - -doCorePasses hsc_env rb us stats guts (to_do : to_dos) - = do - let (us1, us2) = splitUniqSupply us - (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts - doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos - -doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase - -> ModGuts -> IO (SimplCount, ModGuts) -doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-} simplifyPgm mode sws -doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} trBinds cseProgram -doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} liberateCase -doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} trBinds floatInwards -doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f) -doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} trBindsU doStaticArgs -doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} trBinds dmdAnalPgm -doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU wwTopBinds -doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram -doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} trBindsU specConstrProgram -doCorePass CoreDoGlomBinds = trBinds glomBinds -doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} vectorise be -doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat -doCorePass CoreDoNothing = observe (\ _ _ -> return ()) -#ifdef OLD_STRICTNESS -doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} trBinds doOldStrictness -#else -doCorePass CoreDoOldStrictness = panic "CoreDoOldStrictness" -#endif -doCorePass (CoreDoPasses _) = panic "CoreDoPasses" - -#ifdef OLD_STRICTNESS -doOldStrictness dfs binds - = do binds1 <- saBinds dfs binds - binds2 <- cprAnalyse dfs binds1 - return binds2 -#endif - -printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds) - -ruleCheck phase pat hsc_env us rb guts - = do let dflags = hsc_dflags hsc_env - showPass dflags "RuleCheck" - printDump (ruleCheckProgram phase pat rb (mg_binds guts)) - return (zeroSimplCount dflags, guts) - --- Most passes return no stats and don't change rules -trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind]) - -> HscEnv -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, ModGuts) -trBinds do_pass hsc_env us rb guts - = do { binds' <- do_pass dflags (mg_binds guts) - ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) } - where - dflags = hsc_dflags hsc_env - -trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) - -> HscEnv -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, ModGuts) -trBindsU do_pass hsc_env us rb guts - = do { binds' <- do_pass dflags us (mg_binds guts) - ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) } - where - dflags = hsc_dflags hsc_env - --- Observer passes just peek; don't modify the bindings at all -observe :: (DynFlags -> [CoreBind] -> IO a) - -> HscEnv -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, ModGuts) -observe do_pass hsc_env us rb guts - = do { binds <- do_pass dflags (mg_binds guts) - ; return (zeroSimplCount dflags, guts) } - where - dflags = hsc_dflags hsc_env +doCorePass CoreDoGlomBinds = doPassDM glomBinds +doCorePass CoreDoPrintCore = observe printCore +doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat +doCorePass CoreDoNothing = return +doCorePass (CoreDoPasses passes) = doCorePasses passes +doCorePass pass = pprPanic "doCorePass" (ppr pass) \end{code} - %************************************************************************ %* * - Implicit bindings +\subsection{Core pass combinators} %* * %************************************************************************ -Note [Injecting implicit bindings] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to inject the implict bindings right at the end, in CoreTidy. -But some of these bindings, notably record selectors, are not -constructed in an optimised form. E.g. record selector for - data T = MkT { x :: {-# UNPACK #-} !Int } -Then the unfolding looks like - x = \t. case t of MkT x1 -> let x = I# x1 in x -This generates bad code unless it's first simplified a bit. -(Only matters when the selector is used curried; eg map x ys.) -See Trac #2070. - \begin{code} -getImplicitBinds :: TypeEnv -> [CoreBind] -getImplicitBinds type_env - = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env) - ++ concatMap other_implicit_ids (typeEnvElts type_env)) - -- Put the constructor wrappers first, because - -- other implicit bindings (notably the fromT functions arising - -- from generics) use the constructor wrappers. At least that's - -- what External Core likes - where - implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) - - other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc) - -- The "naughty" ones are not real functions at all - -- They are there just so we can get decent error messages - -- See Note [Naughty record selectors] in MkId.lhs - other_implicit_ids (AClass cl) = classSelIds cl - other_implicit_ids _other = [] - - get_defn :: Id -> CoreBind - get_defn id = NonRec id (unfoldingTemplate (idUnfolding id)) +printCore :: a -> [CoreBind] -> IO () +printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) + +ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts +ruleCheck current_phase pat guts = do + rb <- getRuleBase + dflags <- getDynFlags + liftIO $ Err.showPass dflags "RuleCheck" + liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts)) + return guts + + +doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts +doPassDUM do_pass = doPassM $ \binds -> do + dflags <- getDynFlags + us <- getUniqueSupplyM + liftIO $ do_pass dflags us binds + +doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts +doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags)) + +doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts +doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags) + +doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts +doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us) + +doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts +doPassU do_pass = doPassDU (const do_pass) + +-- Most passes return no stats and don't change rules: these combinators +-- let us lift them to the full blown ModGuts+CoreM world +doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts +doPassM bind_f guts = do + binds' <- bind_f (mg_binds guts) + return (guts { mg_binds = binds' }) + +doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts +doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } + +-- Observer passes just peek; don't modify the bindings at all +observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts +observe do_pass = doPassM $ \binds -> do + dflags <- getDynFlags + _ <- liftIO $ do_pass dflags binds + return binds \end{code} %************************************************************************ %* * - Dealing with rules + Gentle simplification %* * %************************************************************************ --- prepareLocalRuleBase takes the CoreBinds and rules defined in this module. --- It attaches those rules that are for local Ids to their binders, and --- returns the remainder attached to Ids in an IdSet. - \begin{code} -prepareRules :: HscEnv - -> ModGuts - -> UniqSupply - -> IO (RuleBase, -- Rule base for imported things, incl - -- (a) rules defined in this module (orphans) - -- (b) rules from other modules in home package - -- but not things from other packages - - ModGuts) -- Modified fields are - -- (a) Bindings have rules attached, - -- (b) Rules are now just orphan rules - -prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) - guts@(ModGuts { mg_binds = binds, mg_deps = deps - , mg_rules = local_rules, mg_rdr_env = rdr_env }) - us - = do { 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 - (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - (mapM (simplRule env) local_rules) - home_pkg_rules = hptRules hsc_env (dep_mods deps) - - -- Find the rules for locally-defined Ids; then we can attach them - -- to the binders in the top-level bindings - -- - -- Reason - -- - It makes the rules easier to look up - -- - It means that transformation rules and specialisations for - -- locally defined Ids are handled uniformly - -- - It keeps alive things that are referred to only from a rule - -- (the occurrence analyser knows about rules attached to Ids) - -- - It makes sure that, when we apply a rule, the free vars - -- of the RHS are more likely to be in scope - -- - The imported rules are carried in the in-scope set - -- which is extended on each iteration by the new wave of - -- local binders; any rules which aren't on the binding will - -- thereby get dropped - (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules - local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals - binds_w_rules = updateBinders local_rule_base binds - - hpt_rule_base = mkRuleBase home_pkg_rules - imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps - - ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" - (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $ - vcat [text "Local rules", pprRules better_rules, - text "", - text "Imported rules", pprRuleBase imp_rule_base]) - - ; return (imp_rule_base, guts { mg_binds = binds_w_rules, - mg_rules = rules_for_imps }) - } +simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do + -> CoreExpr + -> 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" -updateBinders :: RuleBase -> [CoreBind] -> [CoreBind] -updateBinders local_rules binds - = map update_bndrs binds - where - update_bndrs (NonRec b r) = NonRec (update_bndr b) r - update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] - - update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of - Nothing -> bndr - Just rules -> bndr `addIdSpecialisations` rules - -- The binder might have some existing rules, - -- arising from specialisation pragmas -\end{code} + ; us <- mkSplitUniqSupply 's' -Note [Simplifying the left-hand side of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We must do some gentle simplification on the lhs (template) of each -rule. The case that forced me to add this was the fold/build rule, -which without simplification looked like: - fold k z (build (/\a. g a)) ==> ... -This doesn't match unless you do eta reduction on the build argument. -Similarly for a LHS like - augment g (build h) -we do not want to get - augment (\a. g a) (build h) -otherwise we don't match when given an argument like - augment (\a. h a a) (build h) + ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ + simplExprGently (simplEnvForGHCi dflags) expr -\begin{code} -simplRule env rule@(BuiltinRule {}) - = return rule -simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = do (env, bndrs') <- simplBinders env bndrs - args' <- mapM (simplExprGently env) args - rhs' <- simplExprGently env rhs - return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' }) - --- It's important that simplExprGently does eta reduction. --- For example, in a rule like: --- augment g (build h) --- we do not want to get --- augment (\a. g a) (build h) --- otherwise we don't match when given an argument like --- (\a. h a a) --- --- The simplifier does indeed do eta reduction (it's in --- Simplify.completeLam) but only if -O is on. -\end{code} + ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + (pprCoreExpr expr') + + ; return expr' + } -\begin{code} simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- Simplifies an expression -- does occurrence analysis, then simplification @@ -435,7 +277,7 @@ glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] -- analyser as free in f. glomBinds dflags binds - = do { showPass dflags "GlomBinds" ; + = do { Err.showPass dflags "GlomBinds" ; let { recd_binds = [Rec (flattenBinds binds)] } ; return recd_binds } -- Not much point in printing the result... @@ -450,79 +292,88 @@ glomBinds dflags binds %************************************************************************ \begin{code} -simplifyPgm :: SimplifierMode - -> [SimplifierSwitch] - -> HscEnv - -> UniqSupply - -> RuleBase - -> ModGuts - -> IO (SimplCount, ModGuts) -- New bindings - -simplifyPgm mode switches hsc_env us imp_rule_base guts - = do { - showPass dflags "Simplify"; - - (termination_msg, it_count, counts_out, binds') - <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ; - - dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) - "Simplifier statistics" +simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts +simplifyPgm pass guts + = do { hsc_env <- getHscEnv + ; us <- getUniqueSupplyM + ; rb <- getRuleBase + ; liftIOWithCount $ + simplifyPgmIO pass hsc_env us rb guts } + +simplifyPgmIO :: CoreToDo + -> HscEnv + -> UniqSupply + -> RuleBase + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) + hsc_env us hpt_rule_base + guts@(ModGuts { mg_binds = binds, mg_rules = rules + , mg_fam_inst_env = fam_inst_env }) + = do { (termination_msg, it_count, counts_out, guts') + <- do_iteration us 1 [] binds rules + + ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) + "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", - text "", - pprSimplCount counts_out]); + blankLine, + pprSimplCount counts_out]) - endPassIf dump_phase dflags - ("Simplify phase " ++ phase_info ++ " done") - Opt_D_dump_simpl_phases binds'; - - return (counts_out, guts { mg_binds = binds' }) + ; return (counts_out, guts') } where - dflags = hsc_dflags hsc_env - phase_info = case mode of - SimplGently -> "gentle" - SimplPhase n ss -> shows n - . showString " [" - . showString (concat $ intersperse "," ss) - $ "]" - - dump_phase = shouldDumpSimplPhase dflags mode - - sw_chkr = isAmongSimpl switches - max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 - - do_iteration us iteration_no counts binds + dflags = hsc_dflags hsc_env + dump_phase = dumpSimplPhase dflags mode + simpl_env = mkSimplEnv mode + active_rule = activeRule dflags simpl_env + + do_iteration :: UniqSupply + -> Int -- Counts iterations + -> [SimplCount] -- Counts from earlier iterations, reversed + -> [CoreBind] -- Bindings in + -> [CoreRule] -- and orphan rules + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration us iteration_no counts_so_far binds 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 - = WARN(debugIsOn && (max_iterations > 2), - text ("Simplifier still going after " ++ - show max_iterations ++ - " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" )) + = WARN( debugIsOn && (max_iterations > 2) + , ptext (sLit "Simplifier baling out after") <+> int max_iterations + <+> ptext (sLit "iterations") + <+> (brackets $ hsep $ punctuate comma $ + map (int . simplCountN) (reverse counts_so_far)) + <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) ) + -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed - return ("Simplifier bailed out", iteration_no - 1, counts, binds) + return ( "Simplifier baled out", iteration_no - 1 + , totalise counts_so_far + , guts { mg_binds = binds, mg_rules = rules } ) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. | let sz = coreBindsSize binds in sz == sz = do { -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ; - dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm active_rule rules [] binds } ; + Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (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 -- miss the rules for Ids hidden inside imported inlinings eps <- hscEPS hsc_env ; - let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps) - ; simpl_env = mkSimplEnv mode sw_chkr + let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) + ; rule_base2 = extendRuleBaseList rule_base1 rules ; simpl_binds = {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds - ; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ; + ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ; -- Simplify the program -- We do this with a *case* not a *let* because lazy pattern @@ -530,24 +381,23 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts -- With a let, we ended up with -- let -- t = initSmpl ... - -- counts' = snd t + -- counts1 = snd t -- in - -- case t of {(_,counts') -> if counts'=0 then ... } - -- So the conditional didn't force counts', because the + -- case t of {(_,counts1) -> if counts1=0 then ... } + -- So the conditional didn't force counts1, because the -- selection got duplicated. Sigh! - case initSmpl dflags rule_base' fam_envs us1 simpl_binds of { - (binds', counts') -> do { + case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of { + (env1, counts1) -> do { - let { all_counts = counts `plusSimplCount` counts' - ; herald = "Simplifier phase " ++ phase_info ++ - ", iteration " ++ show iteration_no ++ - " out of " ++ show max_iterations + let { binds1 = getFloats env1 + ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules } ; -- Stop if nothing happened; don't dump output - if isZeroSimplCount counts' then - return ("Simplifier reached fixed point", iteration_no, - all_counts, binds') + if isZeroSimplCount counts1 then + return ( "Simplifier reached fixed point", iteration_no + , totalise (counts1 : counts_so_far) -- Include "free" ticks + , guts { mg_binds = binds1, mg_rules = rules1 } ) else do { -- Short out indirections -- We do this *after* at least one run of the simplifier @@ -557,18 +407,35 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts -- -- ToDo: alas, this means that indirection-shorting does not happen at all -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ; + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald - (pprSimplCount counts') ; - endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ; + end_iteration dflags pass iteration_no counts1 binds2 rules1 ; -- Loop - do_iteration us2 (iteration_no + 1) all_counts binds'' - } } } } + do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 + } } } } + | otherwise = panic "do_iteration" where - (us1, us2) = splitUniqSupply us + (us1, us2) = splitUniqSupply us + + -- Remember the counts_so_far are reversed + totalise :: [SimplCount] -> SimplCount + totalise = foldr (\c acc -> acc `plusSimplCount` c) + (zeroSimplCount dflags) + +simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" + +------------------- +end_iteration :: DynFlags -> CoreToDo -> Int + -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () +-- Same as endIteration but with simplifier 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 iteration_no binds rules } \end{code} @@ -595,23 +462,21 @@ 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 [Transferring IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to propagage any useful IdInfo on x_local to x_exported. + STRICTNESS: if we have done strictness analysis, we want the strictness info on 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 [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 -Messing up the rules -~~~~~~~~~~~~~~~~~~~~ -The example that went bad on me at one stage was this one: +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] @@ -644,13 +509,28 @@ And now we get an infinite loop in the rule system -> iterateFB (:) f x -> iterate f x -Tiresome old solution: - don't do shorting out if f has rewrite rules (see shortableIdInfo) - -New solution (I think): +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 +he says. 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 ~~~~~~~~~~~~~ @@ -718,9 +598,10 @@ makeIndEnv binds add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv add_pair (exported_id, Var local_id) env | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id - add_pair (exported_id, rhs) env - = env + 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 becuase of IdInfo stuff @@ -735,23 +616,27 @@ shortMeOut ind_env exported_id local_id not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for then - True - -{- No longer needed - if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules - then True -- See note on "Messing up rules" - else -#ifdef DEBUG - pprTrace "shortMeOut:" (ppr exported_id) -#endif - False --} + if hasShortableIdInfo exported_id + then True -- See Note [Messing up the exported Id's IdInfo] + else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id ) + False else - False + 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 IdInfo] +hasShortableIdInfo id + = isEmptySpecInfo (specInfo info) + && isDefaultInlinePragma (inlinePragInfo info) + where + info = idInfo id ----------------- transferIdInfo :: Id -> Id -> Id +-- See 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 @@ -762,8 +647,8 @@ transferIdInfo exported_id local_id = modifyIdInfo transfer exported_id where local_info = idInfo local_id - transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info - `setWorkerInfo` workerInfo 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 new_info = setSpecInfoHead (idName exported_id)