#include "HsVersions.h"
-import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..),
- DynFlags, DynFlag(..), dopt, dopt_CoreToDo
+import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
+ SimplifierMode(..), DynFlags, DynFlag(..), dopt,
+ dopt_CoreToDo, buildCoreToDo
)
import CoreSyn
-import CoreFVs ( ruleRhsFreeVars )
-import HscTypes ( PersistentCompilerState(..),
- PackageRuleBase, HomeSymbolTable, IsExported, ModDetails(..)
+import TcIface ( loadImportedRules )
+import HscTypes ( HscEnv(..), GhciMode(..),
+ ModGuts(..), ModGuts, Avails,
+ ModDetails(..),
+ HomeModInfo(..), ExternalPackageState(..), hscEPS
)
import CSE ( cseProgram )
-import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
- extendRuleBaseList, addRuleBaseFVs, pprRuleBase,
+import Rules ( RuleBase, emptyRuleBase, ruleBaseIds,
+ extendRuleBaseList, pprRuleBase, getLocalRules,
ruleCheckProgram )
import Module ( moduleEnvElts )
-import PprCore ( pprCoreBindings, pprCoreExpr )
+import Name ( Name, isExternalName )
+import NameSet ( elemNameSet )
+import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( idName, setIdLocalExported )
+import Id ( idName, idIsFrom, idSpecialisation, setIdSpecialisation )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
import SpecConstr ( specConstrProgram)
-import UsageSPInf ( doUsageSPInf )
-import StrictAnal ( saBinds )
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 )
%************************************************************************
\begin{code}
-core2core :: DynFlags -- includes spec of what core-to-core passes to do
- -> PersistentCompilerState
- -> HomeSymbolTable
- -> IsExported
- -> ModDetails
- -> IO ModDetails
-
-core2core dflags pcs hst is_exported
- mod_details@(ModDetails { md_binds = binds_in, md_rules = rules_in })
+core2core :: HscEnv
+ -> ModGuts
+ -> IO ModGuts
+
+core2core hsc_env
+ mod_impl@(ModGuts { mg_binds = binds_in })
= do
- let core_todos = dopt_CoreToDo dflags
- let pkg_rule_base = pcs_rules pcs -- Rule-base accumulated from imported packages
-
+ let dflags = hsc_dflags hsc_env
+ core_todos
+ | Just todo <- dopt_CoreToDo dflags = todo
+ | otherwise = buildCoreToDo dflags
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
- (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
- <- prepareRules dflags pkg_rule_base hst ru_us binds_in rules_in
+ (rule_base, local_rule_ids, orphan_rules)
+ <- prepareRules hsc_env mod_impl ru_us
-- PREPARE THE BINDINGS
- let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds_in
+ let binds1 = updateBinders local_rule_ids 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 (mod_details { md_binds = processed_binds, md_rules = 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
- -> 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
+simplifyExpr dflags expr
= do {
; showPass dflags "Simplify"
; us <- mkSplitUniqSupply 's'
- ; let env = emptySimplEnv (SimplPhase 0) [] emptyVarSet
+ ; let env = emptySimplEnv SimplGently [] emptyVarSet
(expr', _counts) = initSmpl dflags us (simplExprGently env expr)
; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
doCorePass dfs rb us binds CoreDoStaticArgs
= _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
doCorePass dfs rb us binds CoreDoStrictness
- = _scc_ "Stranal" noStats dfs (strictAnal 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 CoreDoSpecConstr
= _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
-#ifdef DEBUG
-doCorePass dfs rb us binds CoreDoCPResult
- = _scc_ "CPResult" noStats dfs (cprAnalyse dfs 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)
doCorePass dfs rb us binds CoreDoNothing
= noStats dfs (return binds)
-strictAnal dfs binds = do
-#ifdef DEBUG
- binds <- saBinds dfs binds
+#ifdef OLD_STRICTNESS
+doOldStrictness dfs binds
+ = do binds1 <- saBinds dfs binds
+ binds2 <- cprAnalyse dfs binds1
+ return binds2
#endif
- dmdAnalPgm dfs binds
printCore binds = do dumpIfSet True "Print Core"
(pprCoreBindings binds)
-- so that the opportunity to apply the rule isn't lost too soon
\begin{code}
-prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable
+prepareRules :: HscEnv
+ -> ModGuts
-> UniqSupply
- -> [CoreBind]
- -> [IdCoreRule] -- Local rules
-> IO (RuleBase, -- Full rule base
IdSet, -- Local rule Ids
- [IdCoreRule], -- Orphan rules
- IdSet) -- RHS free vars of all rules
+ [IdCoreRule]) -- Orphan rules defined in this module
-prepareRules dflags pkg_rule_base hst us binds local_rules
- = do { let env = emptySimplEnv SimplGently [] local_ids
+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
+
+ ; 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 hst)
- 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
+ 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
; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
- (vcat [text "Local rules", pprRuleBase local_rule_base,
+ (vcat [text "Local rules", pprIdRules better_rules,
text "",
text "Imported rules", pprRuleBase final_rule_base])
- ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
+ ; return (final_rule_base, local_rule_ids, orphan_rules)
}
where
- 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.
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
- -> IsExported
-> [CoreBind] -> [CoreBind]
-- A horrible function
--- 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.
+-- Update the binders of top-level bindings by
+-- attaching the rules for each locally-defined Id to that Id.
--
--- Reason for (a)
+-- Reason
-- - It makes the rules easier to look up
-- - It means that transformation rules and specialisations for
-- locally defined Ids are handled uniformly
-- (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 rule_ids rule_rhs_fvs is_exported binds
+
+updateBinders rule_ids 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
- | 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
+ update_bndr bndr = case lookupVarSet rule_ids bndr of
+ Nothing -> bndr
+ Just id -> bndr `setIdSpecialisation` idSpecialisation id
\end{code}
-- 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)
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 us1 (simplTopBinds simpl_env tagged_binds) of {
-- Dump the result of this iteration
dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
- (pprSimplCount counts') ;
+ (pprSimplCount counts') ;
endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
- -- 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 ();
-
- return ("Simplifier baled out", iteration_no, all_counts, 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