From ce26c4b797d4eace56c7acfab5e5d6990b5f1681 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 4 Jan 2002 11:39:01 +0000
Subject: [PATCH] [project @ 2002-01-04 11:39:00 by simonpj]
 ----------------------------- 	Fix a too-vigorous export
 bug 	-----------------------------

	MERGE TO STABLE

	[this is the Ian Lynagh -O2 bug]


CoreTidy didn't filter the rules that it exports, so it
exported some that mentioned Ids on the *left* hand side
that are not exported.  So an importing module fell over.

The fix is simple: filter the exposed rules.   On the way
I tidied up CoreFVs a little.
---
 ghc/compiler/coreSyn/CoreFVs.lhs  |   11 +----------
 ghc/compiler/coreSyn/CoreTidy.lhs |   29 +++++++++++++++++++++--------
 2 files changed, 22 insertions(+), 18 deletions(-)

diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs
index 0bce99b..6b5ca3a 100644
--- a/ghc/compiler/coreSyn/CoreFVs.lhs
+++ b/ghc/compiler/coreSyn/CoreFVs.lhs
@@ -11,8 +11,7 @@ module CoreFVs (
 	exprSomeFreeVars, exprsSomeFreeVars,
 
 	idRuleVars, idFreeVars, idFreeTyVars,
-	ruleSomeFreeVars, ruleRhsFreeVars,
-	ruleLhsFreeNames, ruleLhsFreeIds, 
+	ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, 
 
 	CoreExprWithFVs,	-- = AnnExpr Id VarSet
 	CoreBindWithFVs,	-- = AnnBind Id VarSet
@@ -207,14 +206,6 @@ ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
   where
     rule_fvs = addBndrs tpl_vars (expr_fvs rhs)
 
-ruleSomeFreeVars :: InterestingVarFun -> CoreRule -> VarSet
-ruleSomeFreeVars interesting (BuiltinRule _ _) = noFVs
-ruleSomeFreeVars interesting (Rule _ _ tpl_vars tpl_args rhs)
-  = rule_fvs interesting emptyVarSet
-  where
-    rule_fvs = addBndrs tpl_vars $
-	       foldr (union . expr_fvs) (expr_fvs rhs) tpl_args
-
 ruleLhsFreeIds :: CoreRule -> VarSet
 -- This finds all the free Ids on the LHS of the rule
 -- *including* imported ids
diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index f8842b9..b0dfbd3 100644
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -14,7 +14,7 @@ module CoreTidy (
 import CmdLineOpts	( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
 import CoreSyn
 import CoreUnfold	( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
-import CoreFVs		( ruleSomeFreeVars, exprSomeFreeVars )
+import CoreFVs		( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
 import PprCore		( pprIdCoreRule )
 import CoreLint		( showPass, endPass )
 import CoreUtils	( exprArity )
@@ -137,6 +137,11 @@ tidyCorePgm dflags mod pcs cg_info_env
 
 	; let ext_ids   = findExternalSet   binds_in orphans_in
 	; let ext_rules = findExternalRules binds_in orphans_in ext_ids
+		-- findExternalRules filters ext_rules to avoid binders that 
+		-- aren't externally visible; but the externally-visible binders 
+		-- are computed (by findExternalSet) assuming that all orphan
+		-- rules are exported.  So in fact we may export more than we
+		-- need.  (It's a sort of mutual recursion.)
 
 	-- We also make sure to avoid any exported binders.  Consider
 	--	f{-u1-} = 1	-- Local decl
@@ -248,17 +253,25 @@ findExternalRules :: [CoreBind]
 findExternalRules binds orphan_rules ext_ids
   | opt_OmitInterfacePragmas = []
   | otherwise
-  = orphan_rules ++ local_rules
+  = filter needed_rule (orphan_rules ++ local_rules)
   where
     local_rules  = [ (id, rule)
  		   | id <- bindersOfBinds binds,
 		     id `elemVarEnv` ext_ids,
-		     rule <- rulesRules (idSpecialisation id),
-		     not (isBuiltinRule rule)
-			-- We can't print builtin rules in interface files
-			-- Since they are built in, an importing module
-			-- will have access to them anyway
+		     rule <- rulesRules (idSpecialisation id)
 		 ]
+    needed_rule (id, rule)
+	=  not (isBuiltinRule rule)
+	 	-- We can't print builtin rules in interface files
+		-- Since they are built in, an importing module
+		-- will have access to them anyway
+
+	&& not (any internal_id (varSetElems (ruleLhsFreeIds rule)))
+		-- Don't export a rule whose LHS mentions an Id that
+		-- is completely internal (i.e. not visible to an
+		-- importing module)
+
+    internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids)
 \end{code}
 
 %************************************************************************
@@ -276,7 +289,7 @@ findExternalSet binds orphan_rules
   = foldr find init_needed binds
   where
     orphan_rule_ids :: IdSet
-    orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule 
+    orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule 
 				   | (_, rule) <- orphan_rules]
     init_needed :: IdEnv Bool
     init_needed = mapUFM (\_ -> False) orphan_rule_ids
-- 
1.7.10.4