SimplifierMode(..), DynFlags, DynFlag(..), dopt,
getCoreToDo )
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 ( endPass, 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 IO ( hPutStr, stderr )
import Outputable
import List ( partition )
-import Maybes ( orElse )
+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 CoreDoGlomBinds = trBinds glomBinds
doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} vectorise
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
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
\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:
-- 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 ->
+simplExprGently env expr = do
+ expr1 <- simplExpr env (occurAnalyseExpr expr)
simplExpr env (occurAnalyseExpr expr1)
\end{code}
text "",
pprSimplCount counts_out]);
- endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
+ endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_dump_simpl_phases binds';
return (counts_out, guts { mg_binds = binds' })
}
if max_iterations > 2 then
hPutStr stderr ("NOTE: Simplifier still going after " ++
show max_iterations ++
- " iterations; bailing out. Size = " ++ show (coreBindsSize binds) )
+ " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" )
else
return ();
#endif
-- 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