\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,
import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
- setWorkerInfo, workerInfo,
+ setWorkerInfo, workerInfo, setSpecInfoHead,
setInlinePragInfo, inlinePragInfo,
setSpecInfo, specInfo, specInfoRules )
import CoreUtils ( coreBindsSize )
import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
-import CoreLint ( endPass )
+import CoreLint ( endPassIf, endIteration )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FamInstEnv
-import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
- idSpecialisation, idName )
+import Id
+import DataCon
+import TyCon ( tyConSelIds, tyConDataCons )
+import Class ( classSelIds )
import VarSet
import VarEnv
import NameEnv ( lookupNameEnv )
import CprAnalyse ( cprAnalyse )
#endif
import Vectorise ( vectorise )
+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}
%************************************************************************
-> IO ModGuts
core2core hsc_env guts
- = do
- let dflags = hsc_dflags hsc_env
- core_todos = getCoreToDo dflags
+ = do {
+ ; let dflags = hsc_dflags hsc_env
+ core_todos = getCoreToDo dflags
- us <- mkSplitUniqSupply 's'
- let (cp_us, ru_us) = splitUniqSupply us
+ ; us <- mkSplitUniqSupply 's'
+ ; let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
- (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
+ ; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
+
+ -- Note [Injecting implicit bindings]
+ ; let implicit_binds = getImplicitBinds (mg_types guts1)
+ guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
-- DO THE BUSINESS
- (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
- (zeroSimplCount dflags)
- guts' core_todos
+ ; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us
+ (zeroSimplCount dflags)
+ guts2 core_todos
- dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+ ; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
(pprSimplCount stats)
- return guts''
+ ; return guts3 }
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
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 (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 (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} vectorise be
doCorePass CoreDoPrintCore = observe printCore
-doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
+doCorePass (CoreDoRuleCheck phase pat) = 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
printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
-ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
- printDump (ruleCheckProgram phase pat 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])
\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
%* *
%************************************************************************
local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
env = setInScopeSet gentleSimplEnv local_ids
(better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
- (mapSmpl (simplRule env) local_rules)
+ (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
-- arising from specialisation pragmas
\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)
\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' })
+ = 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:
-- 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}
(termination_msg, it_count, counts_out, binds')
<- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
- dumpIfSet (dopt Opt_D_verbose_core2core dflags
- && dopt Opt_D_dump_simpl_stats dflags)
+ dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics"
(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';
+ endPassIf dump_phase dflags
+ ("Simplify phase " ++ phase_info ++ " done")
+ Opt_D_dump_simpl_phases binds';
return (counts_out, guts { mg_binds = binds' })
}
where
dflags = hsc_dflags hsc_env
phase_info = case mode of
- SimplGently -> "gentle"
- SimplPhase n -> show n
+ 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
-- 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 } ;
+ let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
eps <- hscEPS hsc_env ;
let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
; simpl_env = mkSimplEnv mode sw_chkr
- ; simpl_binds = _scc_ "SimplTopBinds"
+ ; simpl_binds = {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
--
-- 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
(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''
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)
+ `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