\section[SimplCore]{Driver for simplifying @Core@ programs}
\begin{code}
-module SimplCore ( core2core ) where
+module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
- SwitchResult(..), intSwitchSet,
- opt_UsageSPOn,
- DynFlags, DynFlag(..), dopt, dopt_CoreToDo
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
+ SimplifierMode(..), DynFlags, DynFlag(..), dopt,
+ dopt_CoreToDo
)
-import CoreLint ( beginPass, endPass )
import CoreSyn
-import CoreFVs ( ruleSomeFreeVars )
-import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) )
+import CoreFVs ( ruleRhsFreeVars )
+import HscTypes ( HscEnv(..), GhciMode(..),
+ ModGuts(..), ModGuts, Avails, availsToNameSet,
+ PackageRuleBase, HomePackageTable, ModDetails(..),
+ HomeModInfo(..)
+ )
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
- extendRuleBaseList, addRuleBaseFVs )
+ extendRuleBaseList, addRuleBaseFVs, pprRuleBase,
+ ruleCheckProgram )
import Module ( moduleEnvElts )
-import CoreUnfold
-import PprCore ( pprCoreBindings, pprIdCoreRule )
-import OccurAnal ( occurAnalyseBinds )
-import CoreUtils ( etaReduceExpr, coreBindsSize )
+import Name ( Name, isExternalName )
+import NameSet ( elemNameSet )
+import PprCore ( pprCoreBindings, pprCoreExpr )
+import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
+import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import SimplUtils ( simplBinders )
import SimplMonad
-import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
+import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
+import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( Id, isDataConWrapId, setIdNoDiscard )
+import Id ( idName, setIdLocalExported )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
-import UsageSPInf ( doUsageSPInf )
-import StrictAnal ( saBinds )
+import SpecConstr ( specConstrProgram)
+import DmdAnal ( dmdAnalPgm )
import WorkWrap ( wwTopBinds )
+#ifdef OLD_STRICTNESS
+import StrictAnal ( saBinds )
import CprAnalyse ( cprAnalyse )
+#endif
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
import IO ( hPutStr, stderr )
import Outputable
+import Maybes ( orElse )
import List ( partition )
\end{code}
%************************************************************************
\begin{code}
-core2core :: DynFlags -- includes spec of what core-to-core passes to do
- -> PackageRuleBase -- Rule-base accumulated from imported packages
- -> HomeSymbolTable
- -> [CoreBind] -- Binds in
- -> [IdCoreRule] -- Rules in
- -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out
-
-core2core dflags pkg_rule_base hst binds rules
+core2core :: HscEnv
+ -> PackageRuleBase
+ -> ModGuts
+ -> IO ModGuts
+
+core2core hsc_env pkg_rule_base
+ mod_impl@(ModGuts { mg_exports = exports,
+ mg_binds = binds_in,
+ mg_rules = rules_in })
= do
- let core_todos = dopt_CoreToDo dflags
+ let dflags = hsc_dflags hsc_env
+ hpt = hsc_HPT hsc_env
+ ghci_mode = hsc_mode hsc_env
+ core_todos = dopt_CoreToDo dflags
+
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
- (rule_base, binds1, orphan_rules)
- <- prepareRules dflags pkg_rule_base hst ru_us binds rules
+ (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
+ <- prepareRules dflags pkg_rule_base hpt ru_us binds_in rules_in
+ -- PREPARE THE BINDINGS
+ let binds1 = updateBinders ghci_mode local_rule_ids
+ rule_rhs_fvs exports binds_in
-- DO THE BUSINESS
(stats, processed_binds)
-- 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 (processed_binds, orphan_rules)
+ return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
+
+
+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"
+
+ ; us <- mkSplitUniqSupply 's'
+
+ ; let env = emptySimplEnv SimplGently [] emptyVarSet
+ (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+ (pprCoreExpr expr')
+
+ ; return expr'
+ }
doCorePasses :: DynFlags
doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
-doCorePass dfs rb us binds (CoreDoSimplify sw_chkr)
- = _scc_ "Simplify" simplifyPgm dfs rb sw_chkr us binds
+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
doCorePass dfs rb us binds CoreDoStaticArgs
= _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
doCorePass dfs rb us binds CoreDoStrictness
- = _scc_ "Stranal" noStats dfs (saBinds dfs binds)
+ = _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 CoreDoCPResult
- = _scc_ "CPResult" noStats dfs (cprAnalyse dfs 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)
+#endif
doCorePass dfs rb us binds CoreDoPrintCore
= _scc_ "PrintCore" noStats dfs (printCore binds)
-doCorePass dfs rb us binds CoreDoUSPInf
- = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us 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
+ = do binds1 <- saBinds dfs binds
+ binds2 <- cprAnalyse dfs binds1
+ return binds2
+#endif
printCore binds = do dumpIfSet True "Print Core"
(pprCoreBindings binds)
return binds
+ruleCheck dflags phase pat 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) }
+
\end{code}
-- so that the opportunity to apply the rule isn't lost too soon
\begin{code}
-prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
+prepareRules :: DynFlags -> PackageRuleBase -> HomePackageTable
-> UniqSupply
- -> [CoreBind] -> [IdCoreRule] -- Local bindings and rules
- -> IO (RuleBase, -- Full rule base
- [CoreBind], -- Bindings augmented with rules
- [IdCoreRule]) -- Orphan rules
-
-prepareRules dflags pkg_rule_base hst us binds rules
- = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
- (mapSmpl simplRule rules)
+ -> [CoreBind]
+ -> [IdCoreRule] -- Local rules
+ -> IO (RuleBase, -- Full rule base
+ IdSet, -- Local rule Ids
+ [IdCoreRule], -- Orphan rules
+ IdSet) -- RHS free vars of all rules
+
+prepareRules dflags pkg_rule_base hpt us binds local_rules
+ = do { let env = emptySimplEnv SimplGently [] local_ids
+ (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
+
+ ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
+ -- We use (`elemVarSet` local_ids) rather than isLocalId because
+ -- isLocalId isn't true of class methods.
+ -- 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 the
+ -- same as the rule-id set), 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 #-}
+
+ rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
+ local_rule_base = extendRuleBaseList emptyRuleBase local_rules
+ local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached
+ imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
+ rule_base = extendRuleBaseList imp_rule_base orphan_rules
+ final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
+ -- The last step black-lists the free vars of local rules too
; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
- (vcat (map pprIdCoreRule better_rules))
+ (vcat [text "Local rules", pprRuleBase local_rule_base,
+ text "",
+ text "Imported rules", pprRuleBase final_rule_base])
- ; let (local_id_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
- (binds1, local_rule_fvs) = addRulesToBinds binds local_id_rules
- imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst)
- rule_base = extendRuleBaseList imp_rule_base orphan_rules
- final_rule_base = addRuleBaseFVs rule_base local_rule_fvs
- -- The last step black-lists the free vars of local rules too
-
- ; return (final_rule_base, binds1, orphan_rules)
+ ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
}
where
- sw_chkr any = SwBool False -- A bit bogus
- black_list_all v = not (isDataConWrapId v)
- -- This stops all inlining except the
- -- wrappers for data constructors
-
- add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
+ add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
-- Boringly, we need to gather the in-scope set.
- -- Typically this thunk won't even be forced, but the test in
- -- simpVar fails if it isn't right, and it might conceiveably matter
local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], IdSet)
+
+updateBinders :: GhciMode
+ -> IdSet -- Locally defined ids with their Rules attached
+ -> IdSet -- Ids free in the RHS of local rules
+ -> Avails -- What is exported
+ -> [CoreBind] -> [CoreBind]
-- A horrible function
- -- Attach the rules for each locally-defined Id to that Id.
- -- - This 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
- --
- -- Both the LHS and RHS Ids are marked 'no-discard'.
- -- This means that the binding won't be discarded EVEN if the binding
- -- ends up being trivial (v = w) -- the simplifier would usually just
- -- substitute w for v throughout, but we don't apply the substitution to
- -- the rules (maybe we should?), so this substitution would make the rule
- -- bogus.
-
-addRulesToBinds binds local_rules
- = (map zap_bind binds, rule_lhs_fvs)
+-- Update the binders of top-level bindings as follows
+-- a) Attach the rules for each locally-defined Id to that Id.
+-- b) Set the no-discard flag if either the Id is exported,
+-- or it's mentioned in the RHS of a rule
+--
+-- You might wonder why exported Ids aren't already marked as such;
+-- it's just because the type checker is rather busy already and
+-- I didn't want to pass in yet another mapping.
+--
+-- Reason for (a)
+-- - 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
+--
+-- Reason for (b)
+-- It means that the binding won't be discarded EVEN if the binding
+-- ends up being trivial (v = w) -- the simplifier would usually just
+-- substitute w for v throughout, but we don't apply the substitution to
+-- the rules (maybe we should?), so this substitution would make the rule
+-- bogus.
+
+updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds
+ = map update_bndrs binds
where
- -- rule_fvs is the set of all variables mentioned in this module's rules
- rule_fvs = unionVarSets [ ruleSomeFreeVars isId rule | (_,rule) <- local_rules ]
-
- rule_base = extendRuleBaseList emptyRuleBase local_rules
- rule_lhs_fvs = ruleBaseFVs rule_base
- rule_ids = ruleBaseIds rule_base
-
- zap_bind (NonRec b r) = NonRec (zap_bndr b) r
- zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs]
+ 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
+ | dont_discard bndr = setIdLocalExported bndr_with_rules
+ | otherwise = bndr_with_rules
+ where
+ bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
+
+ dont_discard bndr = is_exported (idName bndr)
+ || bndr `elemVarSet` rule_rhs_fvs
+
+ -- In interactive mode, we don't want to discard any top-level
+ -- entities at all (eg. do not inline them away during
+ -- simplification), and retain them all in the TypeEnv so they are
+ -- available from the command line.
+ --
+ -- isExternalName separates the user-defined top-level names from those
+ -- introduced by the type checker.
+ is_exported :: Name -> Bool
+ is_exported | ghci_mode == Interactive = isExternalName
+ | otherwise = (`elemNameSet` export_fvs)
- zap_bndr bndr = case lookupVarSet rule_ids bndr of
- Just bndr' -> setIdNoDiscard bndr'
- Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr
- | otherwise -> bndr
+ export_fvs = availsToNameSet exports
\end{code}
This doesn't match unless you do eta reduction on the build argument.
\begin{code}
-simplRule rule@(id, BuiltinRule _)
+simplRule env rule@(id, BuiltinRule _ _)
= returnSmpl rule
-simplRule rule@(id, Rule name bndrs args rhs)
- = simplBinders bndrs $ \ bndrs' ->
- mapSmpl simpl_arg args `thenSmpl` \ args' ->
- simplExpr rhs `thenSmpl` \ rhs' ->
- returnSmpl (id, Rule name bndrs' args' rhs')
-
-simpl_arg e
--- I've seen rules in which a LHS like
+simplRule env rule@(id, Rule act name bndrs args rhs)
+ = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
+ mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
+ simplExprGently env rhs `thenSmpl` \ rhs' ->
+ returnSmpl (id, Rule act name bndrs' args' rhs')
+
+-- It's important that simplExprGently does eta reduction.
+-- For example, in a rule like:
-- augment g (build h)
--- turns into
+-- we do not want to get
-- augment (\a. g a) (build h)
--- So it's a help to eta-reduce the args as we simplify them.
--- Otherwise we don't match when given an argument like
+-- otherwise we don't match when given an argument like
-- (\a. h a a)
- = simplExpr e `thenSmpl` \ e' ->
- returnSmpl (etaReduceExpr e')
+--
+-- The simplifier does indeed do eta reduction (it's in
+-- Simplify.completeLam) but only if -O is on.
+\end{code}
+
+\begin{code}
+simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+-- Simplifies an expression
+-- does occurrence analysis, then simplification
+-- and repeats (twice currently) because one pass
+-- alone leaves tons of crud.
+-- Used (a) for user expressions typed in at the interactive prompt
+-- (b) the LHS and RHS of a RULE
+--
+-- 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 (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
+ simplExpr env (occurAnalyseGlobalExpr expr1)
\end{code}
-- analyser as free in f.
glomBinds dflags binds
- = do { beginPass dflags "GlomBinds" ;
+ = do { showPass dflags "GlomBinds" ;
let { recd_binds = [Rec (flattenBinds binds)] } ;
return recd_binds }
-- Not much point in printing the result...
\begin{code}
simplifyPgm :: DynFlags
-> RuleBase
- -> (SimplifierSwitch -> SwitchResult)
+ -> SimplifierMode
+ -> [SimplifierSwitch]
-> UniqSupply
-> [CoreBind] -- Input
-> IO (SimplCount, [CoreBind]) -- New bindings
simplifyPgm dflags rule_base
- sw_chkr us binds
+ mode switches us binds
= do {
- beginPass dflags "Simplify";
+ showPass dflags "Simplify";
(termination_msg, it_count, counts_out, binds')
<- iteration us 1 (zeroSimplCount dflags) binds;
text "",
pprSimplCount counts_out]);
- endPass dflags "Simplify"
- (dopt Opt_D_verbose_core2core dflags
- && not (dopt Opt_D_dump_simpl_iterations dflags))
- binds' ;
+ endPass dflags "Simplify" Opt_D_verbose_core2core binds';
return (counts_out, binds')
}
where
- max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
- black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
+ phase_info = case mode of
+ SimplGently -> "gentle"
+ SimplPhase n -> show n
+
imported_rule_ids = ruleBaseIds rule_base
- rule_lhs_fvs = ruleBaseFVs rule_base
+ simpl_env = emptySimplEnv mode switches imported_rule_ids
+ sw_chkr = getSwitchChecker simpl_env
+ max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
iteration us iteration_no counts binds
+ -- 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
+ -- Subtract 1 from iteration_no to get the
+ -- number of iterations we actually completed
+ return ("Simplifier baled 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
-- t = initSmpl ...
-- counts' = snd t
-- in
- -- case t of {(_,counts') -> if counts'=0 then ...
+ -- case t of {(_,counts') -> if counts'=0 then ... }
-- So the conditional didn't force counts', because the
-- selection got duplicated. Sigh!
- case initSmpl dflags sw_chkr us1 imported_rule_ids black_list_fn
- (simplTopBinds tagged_binds)
- of { (binds', counts') -> do {
+ 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' } ;
+ let { 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
else do {
-- Dump the result of this iteration
- dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations
- ("Simplifier iteration " ++ show iteration_no
- ++ " out of " ++ show max_iterations)
- (pprSimplCount counts') ;
-
- if dopt Opt_D_dump_simpl_iterations dflags then
- endPass dflags
- ("Simplifier iteration " ++ show iteration_no ++ " result")
- (dopt Opt_D_verbose_core2core dflags)
- binds'
- else
- return [] ;
-
- -- Stop if we've run out of iterations
- if iteration_no == max_iterations then
- do {
-#ifdef DEBUG
- if max_iterations > 2 then
- hPutStr stderr ("NOTE: Simplifier still going after " ++
- show max_iterations ++
- " iterations; bailing out.\n")
- else
-#endif
- return ();
+ dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
+ (pprSimplCount counts') ;
- return ("Simplifier baled out", iteration_no, all_counts, binds')
- }
+ endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
- -- Else loop
- else iteration us2 (iteration_no + 1) all_counts binds'
+ -- Loop
+ iteration us2 (iteration_no + 1) all_counts binds'
} } } }
where
(us1, us2) = splitUniqSupply us
projects / ghc-hetmet.git / blobdiff