)
import CoreSyn
import TcIface ( loadImportedRules )
-import HscTypes ( HscEnv(..), ModGuts(..), ModGuts,
- ModDetails(..), HomeModInfo(..) )
+import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
+ ModDetails(..), HomeModInfo(..), hscEPS )
import CSE ( cseProgram )
-import Rules ( RuleBase, ruleBaseIds,
- extendRuleBaseList, pprRuleBase, getLocalRules,
- ruleCheckProgram )
+import Rules ( RuleBase, ruleBaseIds, emptyRuleBase,
+ extendRuleBaseList, pprRuleBase, ruleCheckProgram )
import Module ( moduleEnvElts )
import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import SimplMonad
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint ( endPass )
+import Subst ( mkInScopeSet )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import Id ( idIsFrom, idSpecialisation, setIdSpecialisation )
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import IO ( hPutStr, stderr )
import Outputable
-
+import List ( partition )
import Maybes ( orElse )
\end{code}
-> ModGuts
-> IO ModGuts
-core2core hsc_env
- mod_impl@(ModGuts { mg_binds = binds_in })
+core2core hsc_env guts
= do
- let dflags = hsc_dflags hsc_env
+ let dflags = hsc_dflags hsc_env
core_todos
| Just todo <- dopt_CoreToDo dflags = todo
| otherwise = buildCoreToDo dflags
- us <- mkSplitUniqSupply 's'
+ us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
- (rule_base, local_rule_ids, orphan_rules)
- <- prepareRules hsc_env mod_impl ru_us
-
- -- PREPARE THE BINDINGS
- let binds1 = updateBinders local_rule_ids binds_in
+ (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
-- DO THE BUSINESS
- (stats, processed_binds)
- <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
+ (stats, guts'') <- doCorePasses hsc_env cp_us
+ (zeroSimplCount dflags)
+ imp_rule_base guts' core_todos
dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
"Grand total simplifier statistics"
(pprSimplCount stats)
- -- Return results
- -- We only return local orphan rules, i.e., local rules not attached to an Id
- -- The bindings cotain more rules, embedded in the Ids
- return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
+ return guts''
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
; us <- mkSplitUniqSupply 's'
- ; let env = emptySimplEnv SimplGently [] emptyVarSet
+ ; let env = emptySimplEnv SimplGently []
(expr', _counts) = initSmpl dflags us (simplExprGently env expr)
; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
; return expr'
}
-
-doCorePasses :: DynFlags
- -> RuleBase -- the main rule base
- -> SimplCount -- simplifier stats
+doCorePasses :: HscEnv
-> UniqSupply -- uniques
- -> [CoreBind] -- local binds in (with rules attached)
+ -> SimplCount -- simplifier stats
+ -> RuleBase -- the main rule base
+ -> ModGuts -- local binds in (with rules attached)
-> [CoreToDo] -- which passes to do
- -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
+ -> IO (SimplCount, ModGuts)
-doCorePasses dflags rb stats us binds []
- = return (stats, binds)
+doCorePasses hsc_env us stats rb guts []
+ = return (stats, guts)
-doCorePasses dflags rb stats us binds (to_do : to_dos)
+doCorePasses hsc_env us stats rb guts (to_do : to_dos)
= do
let (us1, us2) = splitUniqSupply us
-
- (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
-
- doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
-
-doCorePass dfs rb us binds (CoreDoSimplify mode switches)
- = _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds
-doCorePass dfs rb us binds CoreCSE
- = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
-doCorePass dfs rb us binds CoreLiberateCase
- = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
-doCorePass dfs rb us binds CoreDoFloatInwards
- = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
-doCorePass dfs rb us binds (CoreDoFloatOutwards f)
- = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
-doCorePass dfs rb us binds CoreDoStaticArgs
- = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
-doCorePass dfs rb us binds CoreDoStrictness
- = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds)
-doCorePass dfs rb us binds CoreDoWorkerWrapper
- = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
-doCorePass dfs rb us binds CoreDoSpecialising
- = _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
-doCorePass dfs rb us binds CoreDoSpecConstr
- = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
-#ifdef OLD_STRICTNESS
-doCorePass dfs rb us binds CoreDoOldStrictness
- = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds)
+ (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
+ doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 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
#endif
-doCorePass dfs rb us binds CoreDoPrintCore
- = _scc_ "PrintCore" noStats dfs (printCore binds)
-doCorePass dfs rb us binds CoreDoGlomBinds
- = noStats dfs (glomBinds dfs binds)
-doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
- = noStats dfs (ruleCheck dfs phase pat binds)
-doCorePass dfs rb us binds CoreDoNothing
- = noStats dfs (return binds)
#ifdef OLD_STRICTNESS
-doOldStrictness dfs binds
+doOldStrictness dfs binds
= do binds1 <- saBinds dfs binds
binds2 <- cprAnalyse dfs binds1
return binds2
#endif
-printCore binds = do dumpIfSet True "Print Core"
- (pprCoreBindings binds)
- return binds
+printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
-ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
+ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
printDump (ruleCheckProgram phase pat binds)
- return binds
-
--- most passes return no stats and don't change rules
-noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
+-- Most passes return no stats and don't change rules
+trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
+ -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
+ -> IO (SimplCount, RuleBase, ModGuts)
+trBinds do_pass hsc_env us rb guts
+ = do { binds' <- do_pass dflags (mg_binds guts)
+ ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
+ where
+ dflags = hsc_dflags hsc_env
+
+trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
+ -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
+ -> IO (SimplCount, RuleBase, ModGuts)
+trBindsU do_pass hsc_env us rb guts
+ = do { binds' <- do_pass dflags us (mg_binds guts)
+ ; return (zeroSimplCount dflags, rb, 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, RuleBase, ModGuts)
+observe do_pass hsc_env us rb guts
+ = do { binds <- do_pass dflags (mg_binds guts)
+ ; return (zeroSimplCount dflags, rb, guts) }
+ where
+ dflags = hsc_dflags hsc_env
\end{code}
prepareRules :: HscEnv
-> ModGuts
-> UniqSupply
- -> IO (RuleBase, -- Full rule base
- IdSet, -- Local rule Ids
- [IdCoreRule]) -- Orphan rules defined in this module
+ -> IO (RuleBase, -- Rule base for imported things, incl
+ -- (a) rules defined in this module (orphans)
+ -- (b) rules from other packages
+ -- (c) rules from other modules in home package
+ 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_rules = local_rules, mg_module = this_mod })
us
- = do { pkg_rule_base <- loadImportedRules hsc_env guts
+ = do { eps <- hscEPS hsc_env
- ; let env = emptySimplEnv SimplGently [] local_ids
+ ; 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 (emptySimplEnv SimplGently []) local_ids
(better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
- imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
- full_rule_base = extendRuleBaseList imp_rule_base better_rules
-
- (local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base
- -- NB: the imported rules may include rules for Ids in this module
- -- which is why we suck the local rules out of full_rule_base
-
- orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules
+ (rules_for_locals, orphan_rules) = partition is_local_rule better_rules
+ is_local_rule (id,_) = idIsFrom this_mod id
+ -- Get the rules for locally-defined Ids out of the RuleBase
+ -- If we miss any rules for Ids defined here, then we end up
+ -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
+ -- same as the non-local-rule-id set, so the Id looks as if it's in scope
+ -- and hence should be cloned), and now the binding for the class method
+ -- doesn't have the same Unique as the one in the Class and the tc-env
+ -- Example: class Foo a where
+ -- op :: a -> a
+ -- {-# RULES "op" op x = x #-}
+ --
+ -- NB we can't use isLocalId, because isLocalId isn't true of class methods.
+
+ -- NB: we assume that the imported rules dont include
+ -- rules for Ids in this module; if there is, the above bad things may happen
+
+ pkg_rule_base = eps_rule_base eps
+ hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
+ imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
+
+ -- Update the binders in the local bindings with the lcoal rules
+ -- Update the binders of top-level bindings by
+ -- attaching the rules for each locally-defined Id to that Id.
+ --
+ -- 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
+ local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
+ binds_w_rules = updateBinders local_rule_base binds
; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
(vcat [text "Local rules", pprIdRules better_rules,
text "",
- text "Imported rules", pprRuleBase final_rule_base])
+ text "Imported rules", pprRuleBase imp_rule_base])
- ; return (final_rule_base, local_rule_ids, orphan_rules)
+#ifdef DEBUG
+ ; let bad_rules = filter (idIsFrom this_mod) (varSetElems (ruleBaseIds imp_rule_base))
+ ; WARN( not (null bad_rules), ppr bad_rules ) return ()
+#endif
+ ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
}
where
add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
- -- Boringly, we need to gather the in-scope set.
- local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-
-
-updateBinders :: IdSet -- Locally defined ids with their Rules attached
- -> [CoreBind] -> [CoreBind]
- -- A horrible function
-
--- Update the binders of top-level bindings by
--- attaching the rules for each locally-defined Id to that Id.
---
--- 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 rule_ids binds
+updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
+updateBinders rule_base binds
= map update_bndrs binds
where
+ rule_ids = ruleBaseIds rule_base
+
update_bndrs (NonRec b r) = NonRec (update_bndr b) r
update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
%************************************************************************
\begin{code}
-simplifyPgm :: DynFlags
- -> RuleBase
- -> SimplifierMode
+simplifyPgm :: SimplifierMode
-> [SimplifierSwitch]
+ -> HscEnv
-> UniqSupply
- -> [CoreBind] -- Input
- -> IO (SimplCount, [CoreBind]) -- New bindings
+ -> RuleBase
+ -> ModGuts
+ -> IO (SimplCount, RuleBase, ModGuts) -- New bindings
-simplifyPgm dflags rule_base
- mode switches us binds
+simplifyPgm mode switches hsc_env us rule_base guts
= do {
showPass dflags "Simplify";
- (termination_msg, it_count, counts_out, binds')
- <- iteration us 1 (zeroSimplCount dflags) binds;
+ (termination_msg, it_count, counts_out, rule_base', guts')
+ <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
dumpIfSet (dopt Opt_D_verbose_core2core dflags
&& dopt Opt_D_dump_simpl_stats dflags)
text "",
pprSimplCount counts_out]);
- endPass dflags "Simplify" Opt_D_verbose_core2core binds';
+ endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
- return (counts_out, binds')
+ return (counts_out, rule_base', guts')
}
where
+ dflags = hsc_dflags hsc_env
phase_info = case mode of
SimplGently -> "gentle"
SimplPhase n -> show n
- imported_rule_ids = ruleBaseIds rule_base
- simpl_env = emptySimplEnv mode switches imported_rule_ids
+ simpl_env = emptySimplEnv mode switches
sw_chkr = getSwitchChecker simpl_env
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
- iteration us iteration_no counts binds
+ do_iteration us rule_base iteration_no counts guts
-- 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
#endif
-- 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 baled out", iteration_no - 1, counts, rule_base, guts)
}
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
- | let sz = coreBindsSize binds in sz == sz
+ | let sz = coreBindsSize (mg_binds guts) in sz == sz
= do {
-- Occurrence analysis
- let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
+ let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ;
dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
(pprCoreBindings tagged_binds);
- -- SIMPLIFY
+ -- Get any new rules, and extend the rule base
+ -- (on the side this extends the package rule base in the
+ -- ExternalPackageTable, ready for the next complation
+ -- in --make mode)
+ -- 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
+ new_rules <- loadImportedRules hsc_env guts ;
+ let { rule_base' = extendRuleBaseList rule_base new_rules
+ ; in_scope = mkInScopeSet (ruleBaseIds rule_base')
+ ; simpl_env' = setInScopeSet simpl_env in_scope } ;
+ -- The new rule base Ids are used to initialise
+ -- the in-scope set. That way, the simplifier will change any
+ -- occurrences of the imported id to the one in the imported_rule_ids
+ -- set, which are decorated with their rules.
+
+ -- Simplify the program
-- We do this with a *case* not a *let* because lazy pattern
-- matching bit us with bad space leak!
-- With a let, we ended up with
-- 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 (simplTopBinds simpl_env tagged_binds) of {
+ case initSmpl dflags us1 (simplTopBinds simpl_env' tagged_binds) of {
(binds', counts') -> do {
- -- The imported_rule_ids are used by initSmpl to initialise
- -- the in-scope set. That way, the simplifier will change any
- -- occurrences of the imported id to the one in the imported_rule_ids
- -- set, which are decorated with their rules.
- let { all_counts = counts `plusSimplCount` counts' ;
- herald = "Simplifier phase " ++ phase_info ++
+ let { guts' = guts { mg_binds = binds' }
+ ; all_counts = counts `plusSimplCount` counts'
+ ; herald = "Simplifier phase " ++ phase_info ++
", iteration " ++ show iteration_no ++
" out of " ++ show max_iterations
} ;
-- Stop if nothing happened; don't dump output
if isZeroSimplCount counts' then
- return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
+ return ("Simplifier reached fixed point", iteration_no,
+ all_counts, rule_base', guts')
else do {
-- Dump the result of this iteration
endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
-- Loop
- iteration us2 (iteration_no + 1) all_counts binds'
+ do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
} } } }
where
(us1, us2) = splitUniqSupply us
projects / ghc-hetmet.git / commitdiff