\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/CodingStyle#Warnings
+-- for details
+
module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
setWorkerInfo, workerInfo,
+ setInlinePragInfo, inlinePragInfo,
setSpecInfo, specInfo, specInfoRules )
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
+import FamInstEnv
import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
idSpecialisation, idName )
import VarSet
import StrictAnal ( saBinds )
import CprAnalyse ( cprAnalyse )
#endif
+import Vectorise ( vectorise )
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import IO ( hPutStr, stderr )
; 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"
}
gentleSimplEnv :: SimplEnv
-gentleSimplEnv = mkSimplEnv SimplGently
- (isAmongSimpl [])
- emptyRuleBase
+gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
doCorePasses :: HscEnv
-> RuleBase -- the imported main rule base
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 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
-- 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
text "",
pprSimplCount counts_out]);
- endPass dflags "Simplify" Opt_D_verbose_core2core binds';
+ endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
return (counts_out, guts { mg_binds = binds' })
}
| 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);
-- 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
-- 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'
-- 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
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
-----------------
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
+ `setInlinePragInfo` inlinePragInfo local_info
`setSpecInfo` addSpecInfo (specInfo exp_info)
(specInfo local_info)
\end{code}
projects / ghc-hetmet.git / blobdiff