\section[SimplCore]{Driver for simplifying @Core@ programs}
\begin{code}
-module SimplCore ( core2core ) where
+module SimplCore ( core2core, simplifyExpr ) where
#include "HsVersions.h"
import CoreLint ( showPass, endPass )
import CoreSyn
import CoreFVs ( ruleRhsFreeVars )
-import HscTypes ( PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..) )
+import HscTypes ( PersistentCompilerState(..),
+ PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..)
+ )
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
- extendRuleBaseList, addRuleBaseFVs )
+ extendRuleBaseList, addRuleBaseFVs, pprRuleBase )
import Module ( moduleEnvElts )
import CoreUnfold
-import PprCore ( pprCoreBindings, pprIdCoreRule )
-import OccurAnal ( occurAnalyseBinds )
-import CoreUtils ( etaReduceExpr, coreBindsSize )
+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 FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( idName, isDataConWrapId, setIdNoDiscard, isLocalId )
+import Id ( idName, isDataConWrapId, setIdNoDiscard, isImplicitId )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
+import SpecConstr ( specConstrProgram)
import UsageSPInf ( doUsageSPInf )
import StrictAnal ( saBinds )
import WorkWrap ( wwTopBinds )
\begin{code}
core2core :: DynFlags -- includes spec of what core-to-core passes to do
- -> PackageRuleBase -- Rule-base accumulated from imported packages
+ -> PersistentCompilerState
-> HomeSymbolTable
-> IsExported
- -> [CoreBind] -- Binds in
- -> [IdCoreRule] -- Rules in
- -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out
+ -> ModDetails
+ -> IO ModDetails
-core2core dflags pkg_rule_base hst is_exported binds rules
+core2core dflags pcs hst is_exported
+ mod_details@(ModDetails { md_binds = binds_in, md_rules = rules_in })
= do
- let core_todos = dopt_CoreToDo dflags
+ let core_todos = dopt_CoreToDo dflags
+ let pkg_rule_base = pcs_rules pcs -- Rule-base accumulated from imported packages
+
+
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
- (rule_base, local_rule_stuff, 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 hst ru_us binds_in rules_in
-- PREPARE THE BINDINGS
- let binds1 = updateBinders local_rule_stuff is_exported binds
+ let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported 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_details { md_binds = processed_binds, md_rules = orphan_rules})
+
+
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> CoreExpr
+ -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
+simplifyExpr dflags pcs hst expr
+ = do {
+ ; showPass dflags "Simplify"
+
+ ; us <- mkSplitUniqSupply 's'
+
+ ; let (expr', _counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_nothing
+ (simplExprGently expr)
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+ (pprCoreExpr expr')
+
+ ; return expr'
+ }
+ where
+ sw_chkr any = SwBool False -- A bit bogus
+ black_list_nothing v = False -- Black list nothing
doCorePasses :: DynFlags
= _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)
doCorePass dfs rb us binds CoreDoCPResult
= _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
doCorePass dfs rb us binds CoreDoPrintCore
-> [CoreBind]
-> [IdCoreRule] -- Local rules
-> IO (RuleBase, -- Full rule base
- (IdSet,IdSet), -- Local rule Ids, and RHS fvs
- [IdCoreRule]) -- Orphan rules
+ IdSet, -- Local rule Ids
+ [IdCoreRule], -- Orphan rules
+ IdSet) -- RHS free vars of all rules
-prepareRules dflags pkg_rule_base hst us binds rules
+prepareRules dflags pkg_rule_base hst us binds local_rules
= do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all
- (mapSmpl simplRule rules)
-
- ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
- (vcat (map pprIdCoreRule better_rules))
-
- ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules
- local_rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) local_rules)
+ (mapSmpl simplRule 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 hst)
final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
-- The last step black-lists the free vars of local rules too
- ; return (final_rule_base, (local_rule_ids, local_rule_rhs_fvs), orphan_rules)
+ ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ (vcat [text "Local rules", pprRuleBase local_rule_base,
+ text "",
+ text "Imported rules", pprRuleBase final_rule_base])
+
+ ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
}
where
sw_chkr any = SwBool False -- A bit bogus
add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds)
-- 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
-updateBinders :: (IdSet, -- Locally defined ids with their Rules attached
- IdSet) -- Ids free in the RHS of local rules
+updateBinders :: IdSet -- Locally defined ids with their Rules attached
+ -> IdSet -- Ids free in the RHS of local rules
-> IsExported
-> [CoreBind] -> [CoreBind]
-- A horrible function
-- the rules (maybe we should?), so this substitution would make the rule
-- bogus.
-updateBinders (rule_ids, rule_rhs_fvs) is_exported binds
+updateBinders rule_ids rule_rhs_fvs is_exported binds
= map update_bndrs 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
- | is_exported (idName bndr)
- || bndr `elemVarSet` rule_rhs_fvs = setIdNoDiscard bndr'
- | otherwise = bndr'
+ | isImplicitId bndr = bndr -- Constructors, selectors; doesn't
+ -- make sense to call setIdNoDiscard
+ -- Also can't have rules
+ | dont_discard bndr = setIdNoDiscard bndr_with_rules
+ | otherwise = bndr_with_rules
where
- bndr' = lookupVarSet rule_ids bndr `orElse` bndr
+ bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
+
+ dont_discard bndr = is_exported (idName bndr)
+ || bndr `elemVarSet` rule_rhs_fvs
\end{code}
= returnSmpl rule
simplRule rule@(id, Rule name bndrs args rhs)
= simplBinders bndrs $ \ bndrs' ->
- mapSmpl simpl_arg args `thenSmpl` \ args' ->
- simplExpr rhs `thenSmpl` \ rhs' ->
+ mapSmpl simplExprGently args `thenSmpl` \ args' ->
+ simplExprGently rhs `thenSmpl` \ rhs' ->
returnSmpl (id, Rule name bndrs' args' rhs')
-simpl_arg e
--- I've seen rules in which a LHS like
+-- 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 :: 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
+simplExprGently expr
+ = simplExpr (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
+ simplExpr (occurAnalyseGlobalExpr expr1)
\end{code}
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')
}
++ " 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 [] ;
+ endPass dflags
+ ("Simplifier iteration " ++ show iteration_no ++ " result")
+ Opt_D_dump_simpl_iterations
+ binds' ;
-- Stop if we've run out of iterations
if iteration_no == max_iterations then
projects / ghc-hetmet.git / blobdiff