-loadImportedRules :: HscEnv -> ModGuts -> IO [IdCoreRule]
--- Returns just the new rules added
-loadImportedRules hsc_env guts
- = initIfaceRules hsc_env guts $ do
- { -- Get new rules
- if_rules <- updateEps selectRules
-
- ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules])
-
- ; core_rules <- mapM tc_rule if_rules
-
- -- Debug print
- ; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules)
-
- -- Update the rule base and return it
- ; updateEps (\ eps ->
- let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
- in (eps { eps_rule_base = new_rule_base }, new_rule_base)
- )
-
- -- Strictly speaking, at this point we should go round again, since
- -- typechecking one set of rules may bring in new things which enable
- -- some more rules to come in. But we call loadImportedRules several
- -- times anyway, so I'm going to be lazy and ignore this.
- ; return core_rules
- }
-
-tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule)
- where
- full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule))
-
-selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)])
--- Not terribly efficient. Look at each rule in the pool to see if
--- all its gates are in the type env. If so, take it out of the pool.
--- If not, trim its gates for next time.
-selectRules eps
- = (eps { eps_rules = rules', eps_stats = stats' }, if_rules)
- where
- stats = eps_stats eps
- rules = eps_rules eps
- type_env = eps_PTE eps
- stats' = stats { n_rules_out = n_rules_out stats + length if_rules }
-
- (rules', if_rules) = foldl do_one ([], []) rules
-
- do_one (pool, if_rules) (gates, rule)
- | null gates' = (pool, rule:if_rules)
- | otherwise = ((gates',rule) : pool, if_rules)
- where
- gates' = filter (not . (`elemNameEnv` type_env)) gates
-
-
-tcIfaceRule :: IfaceRule -> IfL IdCoreRule
-tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,
- ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs })
- = bindIfaceBndrs bndrs $ \ bndrs' ->
- do { fn <- tcIfaceExtId fn_rdr
- ; args' <- mappM tcIfaceExpr args
- ; rhs' <- tcIfaceExpr rhs
- ; let rule = Rule rule_name act bndrs' args' rhs'
- ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) }
+tcIfaceRule :: IfaceRule -> IfL CoreRule
+tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
+ ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
+ ifRuleOrph = orph })
+ = do { fn' <- lookupIfaceExt fn
+ ; ~(bndrs', args', rhs') <-
+ -- Typecheck the payload lazily, in the hope it'll never be looked at
+ forkM (ptext SLIT("Rule") <+> ftext name) $
+ bindIfaceBndrs bndrs $ \ bndrs' ->
+ do { args' <- mappM tcIfaceExpr args
+ ; rhs' <- tcIfaceExpr rhs
+ ; return (bndrs', args', rhs') }
+ ; mb_tcs <- mapM ifTopFreeName args
+ ; returnM (Rule { ru_name = name, ru_fn = fn', ru_act = act,
+ ru_bndrs = bndrs', ru_args = args',
+ ru_rhs = rhs', ru_orph = orph,
+ ru_rough = mb_tcs,
+ ru_local = isLocalIfaceExtName fn }) }