X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=c7b2e6919f69e02c54c1b23dd1efc7b2e0832202;hb=609db9ce4ad70c8cf64350b75da03229a7c33b0f;hp=a386a3d6b021e5138480656f480042fff77dbeae;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index a386a3d..c7b2e69 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -4,6 +4,13 @@ \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" @@ -22,16 +29,18 @@ import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, import PprCore ( pprCoreBindings, pprCoreExpr, pprRules ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo ( setNewStrictnessInfo, newStrictnessInfo, - setWorkerInfo, workerInfo, + setWorkerInfo, workerInfo, setSpecInfoHead, + setInlinePragInfo, inlinePragInfo, setSpecInfo, specInfo, specInfoRules ) import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet ) import SimplMonad import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) -import CoreLint ( endPass ) +import CoreLint ( endPass, endIteration ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) +import FamInstEnv import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId, idSpecialisation, idName ) import VarSet @@ -47,6 +56,7 @@ import WorkWrap ( wwTopBinds ) import StrictAnal ( saBinds ) import CprAnalyse ( cprAnalyse ) #endif +import Vectorise ( vectorise ) import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import IO ( hPutStr, stderr ) @@ -100,7 +110,7 @@ simplifyExpr dflags expr ; us <- mkSplitUniqSupply 's' - ; let (expr', _counts) = initSmpl dflags us $ + ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ simplExprGently gentleSimplEnv expr ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" @@ -110,9 +120,7 @@ simplifyExpr dflags expr } gentleSimplEnv :: SimplEnv -gentleSimplEnv = mkSimplEnv SimplGently - (isAmongSimpl []) - emptyRuleBase +gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl []) doCorePasses :: HscEnv -> RuleBase -- the imported main rule base @@ -125,29 +133,38 @@ doCorePasses :: HscEnv 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 (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws -doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram -doCorePass CoreLiberateCase = _scc_ "LiberateCase" trBinds liberateCase -doCorePass CoreDoFloatInwards = _scc_ "FloatInwards" trBinds floatInwards -doCorePass (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" trBindsU (floatOutwards f) -doCorePass CoreDoStaticArgs = _scc_ "StaticArgs" trBinds 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 :: 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" #-} trBinds 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 = {-# SCC "Vectorise" #-} vectorise doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat) +doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat doCorePass CoreDoNothing = observe (\ _ _ -> return ()) #ifdef OLD_STRICTNESS -doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness +doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} trBinds doOldStrictness +#else +doCorePass CoreDoOldStrictness = panic "CoreDoOldStrictness" #endif +doCorePass (CoreDoPasses _) = panic "CoreDoPasses" #ifdef OLD_STRICTNESS doOldStrictness dfs binds @@ -158,8 +175,11 @@ doOldStrictness dfs binds printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds) -ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck" - printDump (ruleCheckProgram phase pat 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]) @@ -223,7 +243,8 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) -- 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 us (mapSmpl (simplRule env) local_rules) + (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ + (mapSmpl (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 @@ -389,7 +410,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts text "", pprSimplCount counts_out]); - endPass dflags "Simplify" Opt_D_verbose_core2core binds'; + endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_dump_simpl_phases binds'; return (counts_out, guts { mg_binds = binds' }) } @@ -411,7 +432,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts if max_iterations > 2 then hPutStr stderr ("NOTE: Simplifier still going after " ++ show max_iterations ++ - " iterations; bailing out.\n") + " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ) else return (); #endif @@ -425,7 +446,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts | let sz = coreBindsSize binds in sz == sz = do { -- Occurrence analysis - let { tagged_binds = _scc_ "OccAnal" occurAnalysePgm binds } ; + let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ; dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); @@ -436,7 +457,10 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts -- 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 rule_base' } ; + ; simpl_env = mkSimplEnv mode sw_chkr + ; simpl_binds = {-# SCC "SimplTopBinds" #-} + simplTopBinds simpl_env tagged_binds + ; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ; -- Simplify the program -- We do this with a *case* not a *let* because lazy pattern @@ -449,7 +473,7 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts -- case t of {(_,counts') -> if counts'=0 then ... } -- So the conditional didn't force counts', because the -- selection got duplicated. Sigh! - case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of { + case initSmpl dflags rule_base' fam_envs us1 simpl_binds of { (binds', counts') -> do { let { all_counts = counts `plusSimplCount` counts' @@ -468,12 +492,15 @@ simplifyPgm mode switches hsc_env us imp_rule_base guts -- 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 - let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ; + -- + -- 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' } ; -- Dump the result of this iteration dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald (pprSimplCount counts') ; - endPass dflags herald Opt_D_dump_simpl_iterations binds'' ; + endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ; -- Loop do_iteration us2 (iteration_no + 1) all_counts binds'' @@ -600,8 +627,8 @@ type IndEnv = IdEnv Id -- Maps local_id -> exported_id shortOutIndirections :: [CoreBind] -> [CoreBind] shortOutIndirections binds | isEmptyVarEnv ind_env = binds - | no_need_to_flatten = binds' - | otherwise = [Rec (flattenBinds binds')] -- See Note [Rules and indirect-zapping] + | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping] + | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff where ind_env = makeIndEnv binds exp_ids = varSetElems ind_env -- These exported Ids are the subjects @@ -663,12 +690,22 @@ shortMeOut ind_env exported_id local_id ----------------- transferIdInfo :: Id -> Id -> Id +-- 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 +-- Overwriting, rather than merging, seems to work ok. 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 - `setSpecInfo` addSpecInfo (specInfo exp_info) - (specInfo local_info) + `setInlinePragInfo` inlinePragInfo local_info + `setSpecInfo` addSpecInfo (specInfo exp_info) new_info + new_info = setSpecInfoHead (idName exported_id) + (specInfo local_info) + -- Remember to set the function-name field of the + -- rules as we transfer them from one function to another \end{code}