dopt_CoreToDo, buildCoreToDo
)
import CoreSyn
-import CoreFVs ( ruleRhsFreeVars )
+import TcIface ( loadImportedRules )
import HscTypes ( HscEnv(..), GhciMode(..),
- ModGuts(..), ModGuts, Avails, availsToNameSet,
+ ModGuts(..), ModGuts, Avails,
ModDetails(..),
HomeModInfo(..), ExternalPackageState(..), hscEPS
)
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, ruleBaseIds,
- extendRuleBaseList, pprRuleBase,
+ extendRuleBaseList, pprRuleBase, getLocalRules,
ruleCheckProgram )
import Module ( moduleEnvElts )
import Name ( Name, isExternalName )
import NameSet ( elemNameSet )
-import PprCore ( pprCoreBindings, pprCoreExpr )
+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 )
-> IO ModGuts
core2core hsc_env
- mod_impl@(ModGuts { mg_exports = exports,
- mg_binds = binds_in,
- mg_rules = rules_in })
+ mod_impl@(ModGuts { mg_binds = binds_in })
= do
let dflags = hsc_dflags hsc_env
- ghci_mode = hsc_mode hsc_env
core_todos
| Just todo <- dopt_CoreToDo dflags = todo
| otherwise = buildCoreToDo dflags
-- COMPUTE THE RULE BASE TO USE
(rule_base, local_rule_ids, orphan_rules)
- <- prepareRules hsc_env ru_us binds_in rules_in
+ <- prepareRules hsc_env mod_impl ru_us
-- PREPARE THE BINDINGS
- let binds1 = updateBinders ghci_mode local_rule_ids
- orphan_rules exports binds_in
+ let binds1 = updateBinders local_rule_ids binds_in
-- DO THE BUSINESS
(stats, processed_binds)
\begin{code}
prepareRules :: HscEnv
+ -> ModGuts
-> UniqSupply
- -> [CoreBind]
- -> [IdCoreRule] -- Local rules
-> IO (RuleBase, -- Full rule base
IdSet, -- Local rule Ids
[IdCoreRule]) -- Orphan rules defined in this module
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
- us binds local_rules
- = do { eps <- hscEPS hsc_env
+ 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 #-}
- 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 (eps_rule_base eps) (moduleEnvElts hpt)
- final_rule_base = extendRuleBaseList imp_rule_base orphan_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
; 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])
local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
-updateBinders :: GhciMode
- -> IdSet -- Locally defined ids with their Rules attached
- -> [IdCoreRule] -- Orphan rules
- -> Avails -- What is exported
+updateBinders :: IdSet -- Locally defined ids with their Rules attached
-> [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 ghci_mode rule_ids orphan_rules exports 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
-
- orph_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) orphan_rules)
- -- An orphan rule must keep alive the free vars
- -- of its right-hand side.
- -- Non-orphan rules are attached to the Id (bndr_with_rules above)
- -- and that keeps the rhs free vars alive
-
- dont_discard bndr = is_exported (idName bndr)
- || bndr `elemVarSet` orph_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)
-
- export_fvs = availsToNameSet exports
+ update_bndr bndr = case lookupVarSet rule_ids bndr of
+ Nothing -> bndr
+ Just id -> bndr `setIdSpecialisation` idSpecialisation id
\end{code}
projects / ghc-hetmet.git / blobdiff