+prepareRules :: HscEnv
+ -> ModGuts
+ -> UniqSupply
+ -> IO (RuleBase, -- Rule base for imported things, incl
+ -- (a) rules defined in this module (orphans)
+ -- (b) rules from other packages
+ -- (c) rules from other modules in home package
+ 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_rules = local_rules, mg_module = this_mod })
+ us
+ = do { eps <- hscEPS hsc_env
+
+ ; 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 (emptySimplEnv SimplGently []) local_ids
+ (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
+
+ (rules_for_locals, orphan_rules) = partition is_local_rule better_rules
+ is_local_rule (id,_) = idIsFrom this_mod id
+ -- Get the rules for locally-defined Ids out of the RuleBase
+ -- 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 (hackily) the
+ -- same as the non-local-rule-id set, so the Id looks as if it's in scope
+ -- and hence should be cloned), 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 #-}
+ --
+ -- NB we can't use isLocalId, because isLocalId isn't true of class methods.
+
+ -- NB: we assume that the imported rules dont include
+ -- rules for Ids in this module; if there is, the above bad things may happen
+
+ pkg_rule_base = eps_rule_base eps
+ hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
+ imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
+
+ -- Update the binders in the local bindings with the lcoal rules
+ -- Update the binders of top-level bindings by
+ -- attaching the rules for each locally-defined Id to that Id.
+ --
+ -- 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
+ local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
+ binds_w_rules = updateBinders local_rule_base binds
+
+ ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
+ (vcat [text "Local rules", pprIdRules better_rules,
+ text "",
+ text "Imported rules", pprRuleBase imp_rule_base])
+
+#ifdef DEBUG
+ ; let bad_rules = filter (idIsFrom this_mod) (varSetElems (ruleBaseIds imp_rule_base))
+ ; WARN( not (null bad_rules), ppr bad_rules ) return ()
+#endif
+ ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
+ }
+ where
+ add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
+
+updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
+updateBinders rule_base binds
+ = map update_bndrs binds