From: simonpj Date: Fri, 26 Jan 2001 15:04:16 +0000 (+0000) Subject: [project @ 2001-01-26 15:04:16 by simonpj] X-Git-Tag: Approximately_9120_patches~2807 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8a412ad430be3513ea2385123979d5ef505a4f77;p=ghc-hetmet.git [project @ 2001-01-26 15:04:16 by simonpj] Fix a bug that meant functions mentioned only in orphan rules were discarded --- diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index be94281..c985f95 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -42,6 +42,7 @@ import Literal ( isLitLitLit ) import FiniteMap ( lookupFM, addToFM ) import Maybes ( maybeToBool, orElse ) import ErrUtils ( showPass ) +import PprCore ( pprIdCoreRule ) import SrcLoc ( noSrcLoc ) import UniqFM ( mapUFM ) import Outputable @@ -170,7 +171,8 @@ findExternalSet :: [CoreBind] -> [IdCoreRule] -> IdEnv Bool -- True <=> show unfolding -- Step 1 from the notes above findExternalSet binds orphan_rules - = foldr find init_needed binds + = pprTrace "fes" (vcat (map pprIdCoreRule orphan_rules) $$ ppr (varSetElems orphan_rule_ids)) $ + foldr find init_needed binds where orphan_rule_ids :: IdSet orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 76dbd65..5bf0fe8 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -62,7 +62,7 @@ core2core :: DynFlags -- includes spec of what core-to-core passes to do -> HomeSymbolTable -> IsExported -> [CoreBind] -- Binds in - -> [IdCoreRule] -- Rules in + -> [IdCoreRule] -- Rules defined in this module -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out core2core dflags pcs hst is_exported binds rules @@ -74,11 +74,11 @@ core2core dflags pcs hst is_exported binds rules let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE - (rule_base, local_rule_stuff, orphan_rules) + (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) <- prepareRules dflags pkg_rule_base hst ru_us binds rules -- PREPARE THE BINDINGS - let binds1 = updateBinders local_rule_stuff is_exported binds + let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds -- DO THE BUSINESS (stats, processed_binds) @@ -198,8 +198,9 @@ prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable -> [CoreBind] -> [IdCoreRule] -- Local rules -> IO (RuleBase, -- Full rule base - (IdSet,IdSet), -- Local rule Ids, and RHS fvs - [IdCoreRule]) -- Orphan rules + IdSet, -- Local rule Ids + [IdCoreRule], -- Orphan rules + IdSet) -- RHS free vars of all rules prepareRules dflags pkg_rule_base hst us binds rules = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all @@ -209,7 +210,7 @@ prepareRules dflags pkg_rule_base hst us binds rules (vcat (map pprIdCoreRule better_rules)) ; let (local_rules, orphan_rules) = partition (isLocalId . fst) better_rules - local_rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) local_rules) + 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) @@ -217,7 +218,7 @@ prepareRules dflags pkg_rule_base hst us binds rules final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base) -- The last step black-lists the free vars of local rules too - ; return (final_rule_base, (local_rule_ids, local_rule_rhs_fvs), orphan_rules) + ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs) } where sw_chkr any = SwBool False -- A bit bogus @@ -233,8 +234,8 @@ prepareRules dflags pkg_rule_base hst us binds rules 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 +updateBinders :: IdSet -- Locally defined ids with their Rules attached + -> IdSet -- Ids free in the RHS of local rules -> IsExported -> [CoreBind] -> [CoreBind] -- A horrible function @@ -260,7 +261,7 @@ updateBinders :: (IdSet, -- Locally defined ids with their Rules attached -- 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 rule_rhs_fvs is_exported binds = map update_bndrs binds where update_bndrs (NonRec b r) = NonRec (update_bndr b) r diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 2789fa8..7c5f5f1 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -349,6 +349,9 @@ tcImports pcs hst get_fixity this_mod decls tcIfaceRules (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) -> + -- When relinking this module from its interface-file decls + -- we'll have IfaceRules that are in fact local to this module + -- That's the reason we we get any local_rules out here tcGetEnv `thenTc` \ unf_env -> let