Commit ce26c4b7 authored by simonpj's avatar simonpj
Browse files

[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.
parent 13a428ca
...@@ -11,8 +11,7 @@ module CoreFVs ( ...@@ -11,8 +11,7 @@ module CoreFVs (
exprSomeFreeVars, exprsSomeFreeVars, exprSomeFreeVars, exprsSomeFreeVars,
idRuleVars, idFreeVars, idFreeTyVars, idRuleVars, idFreeVars, idFreeTyVars,
ruleSomeFreeVars, ruleRhsFreeVars, ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds,
ruleLhsFreeNames, ruleLhsFreeIds,
CoreExprWithFVs, -- = AnnExpr Id VarSet CoreExprWithFVs, -- = AnnExpr Id VarSet
CoreBindWithFVs, -- = AnnBind Id VarSet CoreBindWithFVs, -- = AnnBind Id VarSet
...@@ -207,14 +206,6 @@ ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs) ...@@ -207,14 +206,6 @@ ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs)
where where
rule_fvs = addBndrs tpl_vars (expr_fvs rhs) 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 ruleLhsFreeIds :: CoreRule -> VarSet
-- This finds all the free Ids on the LHS of the rule -- This finds all the free Ids on the LHS of the rule
-- *including* imported ids -- *including* imported ids
......
...@@ -14,7 +14,7 @@ module CoreTidy ( ...@@ -14,7 +14,7 @@ module CoreTidy (
import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
import CoreSyn import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
import PprCore ( pprIdCoreRule ) import PprCore ( pprIdCoreRule )
import CoreLint ( showPass, endPass ) import CoreLint ( showPass, endPass )
import CoreUtils ( exprArity ) import CoreUtils ( exprArity )
...@@ -137,6 +137,11 @@ tidyCorePgm dflags mod pcs cg_info_env ...@@ -137,6 +137,11 @@ tidyCorePgm dflags mod pcs cg_info_env
; let ext_ids = findExternalSet binds_in orphans_in ; let ext_ids = findExternalSet binds_in orphans_in
; let ext_rules = findExternalRules binds_in orphans_in ext_ids ; 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 -- We also make sure to avoid any exported binders. Consider
-- f{-u1-} = 1 -- Local decl -- f{-u1-} = 1 -- Local decl
...@@ -248,17 +253,25 @@ findExternalRules :: [CoreBind] ...@@ -248,17 +253,25 @@ findExternalRules :: [CoreBind]
findExternalRules binds orphan_rules ext_ids findExternalRules binds orphan_rules ext_ids
| opt_OmitInterfacePragmas = [] | opt_OmitInterfacePragmas = []
| otherwise | otherwise
= orphan_rules ++ local_rules = filter needed_rule (orphan_rules ++ local_rules)
where where
local_rules = [ (id, rule) local_rules = [ (id, rule)
| id <- bindersOfBinds binds, | id <- bindersOfBinds binds,
id `elemVarEnv` ext_ids, id `elemVarEnv` ext_ids,
rule <- rulesRules (idSpecialisation id), 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
] ]
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} \end{code}
%************************************************************************ %************************************************************************
...@@ -276,7 +289,7 @@ findExternalSet binds orphan_rules ...@@ -276,7 +289,7 @@ findExternalSet binds orphan_rules
= foldr find init_needed binds = foldr find init_needed binds
where where
orphan_rule_ids :: IdSet orphan_rule_ids :: IdSet
orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule
| (_, rule) <- orphan_rules] | (_, rule) <- orphan_rules]
init_needed :: IdEnv Bool init_needed :: IdEnv Bool
init_needed = mapUFM (\_ -> False) orphan_rule_ids init_needed = mapUFM (\_ -> False) orphan_rule_ids
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment