X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplCore.lhs;h=1a634d5e0ebe86efcca3e9b39d5be48b533bcfc4;hp=316382b7cc424e6e4baee3515f41d3b97d6a6eb8;hb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 316382b..1a634d5 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -4,13 +4,6 @@ \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" @@ -21,30 +14,24 @@ import CoreSubst import HscTypes import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, - extendRuleBaseList, pprRuleBase, pprRulesForUser, - ruleCheckProgram, rulesOfBinds, - addSpecInfo, addIdSpecialisations ) -import PprCore ( pprCoreBindings, pprCoreExpr, pprRules ) + extendRuleBaseList, ruleCheckProgram, addSpecInfo, ) +import PprCore ( pprCoreBindings, pprCoreExpr ) import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) -import SimplUtils ( simplEnvForGHCi, simplEnvForRules ) +import SimplUtils ( simplEnvForGHCi, activeRule ) import SimplEnv import SimplMonad import CoreMonad import qualified ErrUtils as Err -import CoreLint import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv import Id -import DataCon -import TyCon ( tyConDataCons ) -import BasicTypes ( CompilerPhase, isActive, isDefaultInlinePragma ) +import BasicTypes ( CompilerPhase, isDefaultInlinePragma ) import VarSet import VarEnv -import NameEnv ( lookupNameEnv ) import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram) @@ -58,9 +45,6 @@ import Util import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import Outputable import Control.Monad -import Data.List -import System.IO -import Maybes \end{code} %************************************************************************ @@ -134,19 +118,20 @@ doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} doPassU wwTopBinds doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - doPassU specProgram + specProgram doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} specConstrProgram -doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} - vectorise be +doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} + vectorise 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} %************************************************************************ @@ -156,6 +141,7 @@ doCorePass (CoreDoPasses passes) = doCorePasses passes %************************************************************************ \begin{code} +printCore :: a -> [CoreBind] -> IO () printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts @@ -167,11 +153,6 @@ ruleCheck current_phase pat guts = do return guts -doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts -doPassDMS do_pass = doPassM $ \binds -> do - dflags <- getDynFlags - liftIOWithCount $ do_pass dflags binds - doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts doPassDUM do_pass = doPassM $ \binds -> do dflags <- getDynFlags @@ -197,11 +178,6 @@ doPassM bind_f guts = do binds' <- bind_f (mg_binds guts) return (guts { mg_binds = binds' }) -doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts -doPassMG bind_f guts = do - binds' <- bind_f 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) } @@ -209,7 +185,7 @@ doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) } observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts observe do_pass = doPassM $ \binds -> do dflags <- getDynFlags - liftIO $ do_pass dflags binds + _ <- liftIO $ do_pass dflags binds return binds \end{code} @@ -331,7 +307,7 @@ simplifyPgmIO :: CoreToDo -> ModGuts -> IO (SimplCount, ModGuts) -- New bindings -simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches) +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 }) @@ -347,9 +323,11 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches) ; return (counts_out, guts') } where - dflags = hsc_dflags hsc_env - dump_phase = dumpSimplPhase dflags mode - sw_chkr = isAmongSimpl switches + 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 @@ -379,7 +357,8 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches) | let sz = coreBindsSize binds in sz == sz = do { -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ; + let { tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm active_rule rules binds } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); @@ -392,7 +371,6 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches) eps <- hscEPS hsc_env ; let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) ; rule_base2 = extendRuleBaseList rule_base1 rules - ; 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) } ; @@ -436,7 +414,8 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches) -- Loop do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1 - } } } } + } } } } + | otherwise = panic "do_iteration" where (us1, us2) = splitUniqSupply us @@ -445,6 +424,8 @@ simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches) totalise = foldr (\c acc -> acc `plusSimplCount` c) (zeroSimplCount dflags) +simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO" + ------------------- end_iteration :: DynFlags -> CoreToDo -> Int -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () @@ -617,10 +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