-\begin{code}
-prepareRules :: HscEnv
- -> ModGuts
- -> UniqSupply
- -> IO (RuleBase, -- Rule base for imported things, incl
- -- (a) rules defined in this module (orphans)
- -- (b) rules from other modules in home package
- -- but not things from other packages
-
- 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_deps = deps
- , mg_rules = local_rules, mg_rdr_env = rdr_env })
- us
- = do { 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 gentleSimplEnv local_ids
- (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
- (mapM (simplRule env) local_rules)
- home_pkg_rules = hptRules hsc_env (dep_mods deps)
-
- -- Find the rules for locally-defined Ids; then we can attach them
- -- to the binders in the top-level bindings
- --
- -- 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
- (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
- local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
- binds_w_rules = updateBinders local_rule_base binds
-
- hpt_rule_base = mkRuleBase home_pkg_rules
- imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
-
- ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
- (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
- vcat [text "Local rules", pprRules better_rules,
- text "",
- text "Imported rules", pprRuleBase imp_rule_base])
-
- ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
- mg_rules = rules_for_imps })
- }