[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.

diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs
index 0bce99b..6b5ca3a 100644 (file)
--- 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 (file)
--- 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