\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 )
+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}
%************************************************************************
%************************************************************************
\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 be) = {-# SCC "Vectorise" #-}
+ vectorise be
-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 = {-# SCC "Vectorise" #-} vectorise
-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 })
- 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"
- (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 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
-- 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...
%************************************************************************
\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 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 { (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]);
-
- endPassIf dump_phase dflags
- ("Simplify phase " ++ phase_info ++ " done")
- Opt_D_dump_simpl_phases binds';
+ blankLine,
+ pprSimplCount counts_out])
- 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
+ sw_chkr = isAmongSimpl switches
+ 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
- = do {
- when (debugIsOn && (max_iterations > 2)) $
- hPutStr stderr ("NOTE: 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 binds rules } ;
+ 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_env = mkSimplEnv sw_chkr mode
; 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
-- 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
--
-- 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}
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]
-> 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 = <stuff>
+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
~~~~~~~~~~~~~
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
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
= 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)