From: simonpj <unknown>
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