\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 )
+ getCoreToDo, shouldDumpSimplPhase )
import CoreSyn
-import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
- Dependencies( dep_mods ),
- hscEPS, hptRules )
+import HscTypes
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
- extendRuleBaseList, pprRuleBase, ruleCheckProgram,
+ extendRuleBaseList, pprRuleBase, pprRulesForUser,
+ ruleCheckProgram, rulesOfBinds,
addSpecInfo, addIdSpecialisations )
import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
- setWorkerInfo, workerInfo,
+ setUnfoldingInfo, unfoldingInfo, 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 CoreMonad
+import qualified ErrUtils as Err ( dumpIfSet_dyn, dumpIfSet, showPass )
+import CoreLint ( showPass, endPass, endPassIf, endIteration )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
- idSpecialisation, idName )
+import FamInstEnv
+import Id
+import DataCon
+import TyCon ( tyConSelIds, tyConDataCons )
+import Class ( classSelIds )
+import BasicTypes ( CompilerPhase, isActive )
import VarSet
import VarEnv
import NameEnv ( lookupNameEnv )
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 List ( partition )
-import Maybes ( orElse )
+import Control.Monad
+import List ( partition, intersperse )
+import Maybes
\end{code}
%************************************************************************
-> ModGuts
-> IO ModGuts
-core2core hsc_env guts
- = do
- let dflags = hsc_dflags hsc_env
- core_todos = getCoreToDo dflags
+core2core hsc_env guts = do
+ let dflags = hsc_dflags hsc_env
+
+ 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
+ (imp_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.
+ -- 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.
+ let mod = mg_module guts
+ (guts, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
+ -- FIND BUILT-IN PASSES
+ let builtin_core_todos = getCoreToDo dflags
- us <- mkSplitUniqSupply 's'
- let (cp_us, ru_us) = splitUniqSupply us
+ -- Note [Injecting implicit bindings]
+ let implicit_binds = getImplicitBinds (mg_types guts1)
+ guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
- -- COMPUTE THE RULE BASE TO USE
- (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
+ -- DO THE BUSINESS
+ doCorePasses builtin_core_todos guts2
- -- DO THE BUSINESS
- (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
- (zeroSimplCount dflags)
- guts' core_todos
+ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+ "Grand total simplifier statistics"
+ (pprSimplCount stats)
- dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
- "Grand total simplifier statistics"
- (pprSimplCount stats)
+ return guts
- return guts''
+type CorePass = CoreToDo
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
-> CoreExpr
-- expression typed in at the interactive prompt
simplifyExpr dflags expr
= do {
- ; showPass dflags "Simplify"
+ ; Err.showPass dflags "Simplify"
; 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"
+ ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
; return expr'
}
gentleSimplEnv :: SimplEnv
-gentleSimplEnv = mkSimplEnv SimplGently
- (isAmongSimpl [])
- emptyRuleBase
-
-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 (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 CoreDoGlomBinds = trBinds glomBinds
-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
+gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
+
+doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
+doCorePasses passes guts = foldM (flip doCorePass) guts passes
+
+doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
+doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
+ simplifyPgm mode sws
+
+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 $
+ doPassDU 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 CoreDoNothing = return
+doCorePass (CoreDoPasses passes) = doCorePasses passes
+
#ifdef OLD_STRICTNESS
-doOldStrictness dfs binds
- = do binds1 <- saBinds dfs binds
- binds2 <- cprAnalyse dfs binds1
- return binds2
+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
-printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Core pass combinators}
+%* *
+%************************************************************************
-ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
- printDump (ruleCheckProgram phase pat binds)
+\begin{code}
--- 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
+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 $ showPass dflags name
+ guts' <- pass guts
+ liftIO $ endPass dflags name dflag (mg_binds 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))
+ 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
+ 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' })
+
+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) }
-- 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
+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}
+%************************************************************************
+%* *
+ Implicit bindings
+%* *
+%************************************************************************
+
+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))
+\end{code}
+
%************************************************************************
%* *
-\subsection{Dealing with rules}
+ Dealing with rules
%* *
%************************************************************************
ModGuts) -- Modified fields are
-- (a) Bindings have rules attached,
+ -- and INLINE rules simplified
-- (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 })
+ guts@(ModGuts { mg_binds = binds, mg_deps = deps
+ , mg_rules = local_rules, mg_rdr_env = rdr_env })
us
- = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
+ = do { us <- mkSplitUniqSupply 'w'
+
+ ; 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 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
- -- 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,
+ (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+ mapM (simplRule env) local_rules
+
+ ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
+
+ home_pkg_rules = hptRules hsc_env (dep_mods deps)
+ hpt_rule_base = mkRuleBase home_pkg_rules
+ imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
+
+ binds_w_rules = updateBinders rules_for_locals binds
+
+
+ ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
+ vcat [text "Local rules", pprRules simpl_rules,
text "",
text "Imported rules", pprRuleBase imp_rule_base])
mg_rules = rules_for_imps })
}
-updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
-updateBinders local_rules binds
- = map update_bndrs binds
+-- Note [Attach rules to local ids]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- 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
+
+updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
+updateBinders rules_for_locals binds
+ = map update_bind 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
+ local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
+
+ update_bind (NonRec b r) = NonRec (add_rules b) r
+ update_bind (Rec prs) = Rec (mapFst add_rules prs)
+
+ -- See Note [Attach rules to local ids]
+ -- NB: the binder might have some existing rules,
+ -- arising from specialisation pragmas
+ add_rules bndr
+ | Just rules <- lookupNameEnv local_rules (idName bndr)
+ = bndr `addIdSpecialisations` rules
+ | otherwise
+ = bndr
\end{code}
-
-We must do some gentle simplification on the template (but not the RHS)
-of each rule. The case that forced me to add this was the fold/build rule,
+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)
+
+The simplifier does indeed do eta reduction (it's in
+Simplify.completeLam) but only if -O is on.
\begin{code}
simplRule env rule@(BuiltinRule {})
- = returnSmpl rule
+ = return rule
simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
- = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
- mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
- simplExprGently env rhs `thenSmpl` \ rhs' ->
- returnSmpl (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.
+ = 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' })
\end{code}
\begin{code}
-- alone leaves tons of crud.
-- Used (a) for user expressions typed in at the interactive prompt
-- (b) the LHS and RHS of a RULE
+-- (c) Template Haskell splices
--
-- The name 'Gently' suggests that the SimplifierMode is SimplGently,
-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
-- enforce that; it just simplifies the expression twice
-simplExprGently env expr
- = simplExpr env (occurAnalyseExpr expr) `thenSmpl` \ expr1 ->
+-- It's important that simplExprGently does eta reduction; see
+-- Note [Simplifying the left-hand side of a RULE] above. The
+-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
+-- but only if -O is on.
+
+simplExprGently env expr = do
+ expr1 <- simplExpr env (occurAnalyseExpr expr)
simplExpr env (occurAnalyseExpr expr1)
\end{code}
-- 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
+simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
+simplifyPgm mode switches
+ = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
+ do { hsc_env <- getHscEnv
+ ; us <- getUniqueSupplyM
+ ; rb <- getRuleBase
+ ; let fam_inst_env = mg_fam_inst_env guts
+ dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode
+ simplify_pgm = simplifyPgmIO dump_phase mode switches
+ hsc_env us rb fam_inst_env
+
+ ; doPassM (liftIOWithCount . simplify_pgm) guts }
+ where
+ doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
+
+simplifyPgmIO :: Bool
+ -> SimplifierMode
-> [SimplifierSwitch]
-> HscEnv
-> UniqSupply
-> RuleBase
- -> ModGuts
- -> IO (SimplCount, ModGuts) -- New bindings
+ -> FamInstEnv
+ -> [CoreBind]
+ -> IO (SimplCount, [CoreBind]) -- New bindings
-simplifyPgm mode switches hsc_env us imp_rule_base guts
+simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
= do {
- showPass dflags "Simplify";
-
(termination_msg, it_count, counts_out, binds')
- <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
+ <- do_iteration us 1 (zeroSimplCount dflags) binds ;
- dumpIfSet (dopt Opt_D_verbose_core2core dflags
- && dopt Opt_D_dump_simpl_stats dflags)
- "Simplifier statistics"
+ 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]);
- endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
-
- return (counts_out, guts { mg_binds = binds' })
+ return (counts_out, binds')
}
where
dflags = hsc_dflags hsc_env
- phase_info = case mode of
- SimplGently -> "gentle"
- SimplPhase n -> show n
sw_chkr = isAmongSimpl switches
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
-- 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 {
-#ifdef DEBUG
- if max_iterations > 2 then
- hPutStr stderr ("NOTE: Simplifier still going after " ++
- show max_iterations ++
- " iterations; bailing out.\n")
- else
- return ();
-#endif
+ = WARN(debugIsOn && (max_iterations > 2),
+ text ("Simplifier still going after " ++
+ show max_iterations ++
+ " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
-- Subtract 1 from iteration_no to get the
-- number of iterations we actually completed
- return ("Simplifier baled out", iteration_no - 1, counts, binds)
- }
+ return ("Simplifier bailed out", iteration_no - 1, counts, binds)
-- 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 } ;
+ Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
-- Get any new rules, and extend the rule base
-- 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, fam_inst_env) } ;
-- 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'
- ; herald = "Simplifier phase " ++ phase_info ++
+ ; herald = "Simplifier mode " ++ showPpr mode ++
", iteration " ++ show iteration_no ++
" out of " ++ show max_iterations
} ;
--
-- 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 { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
-- Dump the result of this iteration
- dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
+ Err.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''
where
local_info = idInfo local_id
transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
- `setWorkerInfo` workerInfo local_info
+ `setUnfoldingInfo` unfoldingInfo local_info
`setInlinePragInfo` inlinePragInfo local_info
- `setSpecInfo` addSpecInfo (specInfo exp_info)
- (specInfo 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}
projects / ghc-hetmet.git / blobdiff