#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 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
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
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.
-- _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
-> 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"
; 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')
; return expr'
}
-gentleSimplEnv :: SimplEnv
-gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
-
doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
-doCorePasses passes guts = foldM (flip doCorePass) guts passes
+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' }
doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
-doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
- simplifyPgm mode sws
+doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}
+ simplifyPgm pass
doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
- describePass "Common sub-expression" Opt_D_dump_cse $
doPass cseProgram
doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
- describePass "Liberate case" Opt_D_verbose_core2core $
doPassD liberateCase
doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
- describePass "Float inwards" Opt_D_verbose_core2core $
doPass floatInwards
doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
- describePassD (text "Float out" <+> parens (ppr f))
- Opt_D_verbose_core2core $
doPassDUM (floatOutwards f)
doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
- describePass "Static argument" Opt_D_verbose_core2core $
doPassU doStaticArgs
doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
- describePass "Demand analysis" Opt_D_dump_stranal $
doPassDM dmdAnalPgm
doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
- describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
doPassU wwTopBinds
doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
- describePassR "Specialise" Opt_D_dump_spec $
doPassU specProgram
doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
- describePassR "SpecConstr" Opt_D_dump_spec $
specConstrProgram
doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
- describePass "Vectorisation" Opt_D_dump_vect $
vectorise be
-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 CoreDoGlomBinds = doPassDM glomBinds
+doCorePass CoreDoPrintCore = observe printCore
+doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
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}
%************************************************************************
%************************************************************************
\begin{code}
-
-dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-dontDescribePass = ($)
-
-describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePass name dflag pass guts = do
- dflags <- getDynFlags
-
- liftIO $ Err.showPass dflags name
- guts' <- pass guts
- liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
-
- return guts'
-
-describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePassD doc = describePass (showSDoc doc)
-
-describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
-describePassR name dflag pass guts = do
- guts' <- describePass name dflag pass guts
- dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
- (pprRulesForUser (rulesOfBinds (mg_binds guts')))
- return guts'
-
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
; 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
; 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 })
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 })
%************************************************************************
\begin{code}
-simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
-simplifyPgm mode switches
- = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
- do { hsc_env <- getHscEnv
+simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
+simplifyPgm pass guts
+ = do { hsc_env <- getHscEnv
; us <- getUniqueSupplyM
; rb <- getRuleBase
; liftIOWithCount $
- simplifyPgmIO mode switches hsc_env us rb guts }
- where
- doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
+ simplifyPgmIO pass hsc_env us rb guts }
-simplifyPgmIO :: SimplifierMode
- -> [SimplifierSwitch]
+simplifyPgmIO :: CoreToDo
-> HscEnv
-> UniqSupply
-> RuleBase
-> ModGuts
-> IO (SimplCount, ModGuts) -- New bindings
-simplifyPgmIO mode switches hsc_env us hpt_rule_base
+simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
+ hsc_env us hpt_rule_base
guts@(ModGuts { mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
= do {
}
where
dflags = hsc_dflags hsc_env
- dump_phase = shouldDumpSimplPhase dflags mode
-
- sw_chkr = isAmongSimpl switches
- max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
-
+ dump_phase = dumpSimplPhase dflags mode
+ sw_chkr = isAmongSimpl switches
do_iteration :: UniqSupply
-> Int -- Counts iterations
-> SimplCount -- Logs optimisations performed
(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
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) } ;
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
let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
-- Dump the result of this iteration
- end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
+ end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
-- Loop
do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
(us1, us2) = splitUniqSupply us
-------------------
-end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
+end_iteration :: DynFlags -> CoreToDo -> Int
-> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
-- 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) ;
+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_name Opt_D_dump_simpl_iterations binds rules }
- where
- pass_name = "Simplifier mode " ++ showPpr mode ++
- ", iteration " ++ show iteration_no ++
- " out of " ++ show max_iterations
+ ; endIteration dflags pass iteration_no binds rules }
\end{code}
= 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
projects / ghc-hetmet.git / blobdiff