Commit 7e7c11b2 authored by simonpj's avatar simonpj
Browse files

[project @ 2003-10-13 10:43:02 by simonpj]

Deal corectly with rules for Ids defined in this module,
even when they are imported (as orphans) from other modules.

The epicentre for this stuff is SimplCore.
parent edb232e6
......@@ -185,7 +185,7 @@ import TcRnMonad
import TcRnTypes ( ImportAvails(..), mkModDeps )
import HscTypes ( ModIface(..),
ModGuts(..), ModGuts, IfaceExport,
GhciMode(..), noDependencies,
GhciMode(..),
HscEnv(..), hscEPS,
Dependencies(..), FixItem(..),
isImplicitTyThing,
......@@ -741,7 +741,7 @@ checkOldIface hsc_env mod iface_path source_unchanged maybe_iface
= do { showPass (hsc_dflags hsc_env)
("Checking old interface for " ++ moduleUserString mod) ;
; initIfaceIO hsc_env noDependencies {- wrong? -} $
; initIfaceCheck hsc_env $
check_old_iface mod iface_path source_unchanged maybe_iface
}
......
......@@ -27,7 +27,7 @@ import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
ModIface(..), ModDetails(..), InstPool, Dependencies(..),
ModIface(..), ModDetails(..), InstPool, ModGuts,
TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
import InstEnv ( extendInstEnv )
......@@ -492,19 +492,21 @@ are in the type environment. However, remember that typechecking a Rule may
(as a side effect) augment the type envt, and so we may need to iterate the process.
\begin{code}
loadImportedRules :: HscEnv -> Dependencies -> IO PackageRuleBase
loadImportedRules hsc_env deps
= initIfaceIO hsc_env deps $ do
loadImportedRules :: HscEnv -> ModGuts -> IO PackageRuleBase
loadImportedRules hsc_env guts
= initIfaceRules hsc_env guts $ do
{ -- Get new rules
if_rules <- updateEps (\ eps ->
let { (new_pool, if_rules) = selectRules (eps_rules eps) (eps_PTE eps) }
in (eps { eps_rules = new_pool }, if_rules) )
; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules))
; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
; core_rules <- mapM tc_rule if_rules
-- Debug print
; traceIf (ptext SLIT("Importing rules:") <+> pprIdRules core_rules)
; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules)
-- Update the rule base and return it
; updateEps (\ eps ->
......
......@@ -22,12 +22,12 @@ import HscTypes ( HscEnv(..), GhciMode(..),
)
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, ruleBaseIds,
extendRuleBaseList, pprRuleBase,
extendRuleBaseList, pprRuleBase, getLocalRules,
ruleCheckProgram )
import Module ( moduleEnvElts )
import Name ( Name, isExternalName )
import NameSet ( elemNameSet )
import PprCore ( pprCoreBindings, pprCoreExpr )
import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
......@@ -37,7 +37,7 @@ import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
import CoreLint ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import Id ( idName, setIdLocalExported )
import Id ( idName, idIsFrom, setIdLocalExported )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
......@@ -222,32 +222,23 @@ prepareRules :: HscEnv
[IdCoreRule]) -- Orphan rules defined in this module
prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
(ModGuts { mg_binds = binds, mg_rules = local_rules,
mg_deps = deps })
guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod })
us
= do { pkg_rule_base <- loadImportedRules hsc_env deps
= do { pkg_rule_base <- loadImportedRules hsc_env guts
; let env = emptySimplEnv SimplGently [] local_ids
(better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
-- We use (`elemVarSet` local_ids) rather than isLocalId because
-- isLocalId isn't true of class methods.
-- If we miss any rules for Ids defined here, then we end up
-- giving the local decl a new Unique (because the in-scope-set is the
-- same as the rule-id set), and now the binding for the class method
-- doesn't have the same Unique as the one in the Class and the tc-env
-- Example: class Foo a where
-- op :: a -> a
-- {-# RULES "op" op x = x #-}
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 hpt)
final_rule_base = extendRuleBaseList imp_rule_base orphan_rules
imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
full_rule_base = extendRuleBaseList imp_rule_base better_rules
(local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base
-- NB: the imported rules may include rules for Ids in this module
orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules
; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
(vcat [text "Local rules", pprRuleBase local_rule_base,
(vcat [text "Local rules", pprIdRules better_rules,
text "",
text "Imported rules", pprRuleBase final_rule_base])
......
......@@ -7,7 +7,7 @@
module Rules (
RuleBase, emptyRuleBase,
extendRuleBase, extendRuleBaseList,
ruleBaseIds,
ruleBaseIds, getLocalRules,
pprRuleBase, ruleCheckProgram,
lookupRule, addRule, addIdSpecialisations
......@@ -25,20 +25,21 @@ import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst,
substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
bindSubstList, unBindSubstList, substInScope, uniqAway
)
import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
import Id ( Id, idIsFrom, idUnfolding, idSpecialisation, setIdSpecialisation )
import Var ( isId )
import VarSet
import VarEnv
import TcType ( mkTyVarTy )
import qualified TcType ( match )
import BasicTypes ( Activation, CompilerPhase, isActive )
import Module ( Module )
import Outputable
import FastString
import Maybe ( isJust, isNothing, fromMaybe )
import Util ( sortLt )
import Bag
import List ( isPrefixOf )
import List ( isPrefixOf, partition )
\end{code}
......@@ -607,6 +608,23 @@ extendRuleBase (RuleBase rule_ids) (id, rule)
-- in which case it may have rules in its belly already. Seems
-- dreadfully hackoid.
getLocalRules :: Module -> RuleBase -> (IdSet, -- Ids with local rules
RuleBase) -- Non-local rules
-- Get the rules for locally-defined Ids out of the RuleBase
-- If we miss any rules for Ids defined here, then we end up
-- giving the local decl a new Unique (because the in-scope-set is the
-- same as the rule-id set), and now the binding for the class method
-- doesn't have the same Unique as the one in the Class and the tc-env
-- Example: class Foo a where
-- op :: a -> a
-- {-# RULES "op" op x = x #-}
--
-- NB we can't use isLocalId, because isLocalId isn't true of class methods.
getLocalRules this_mod (RuleBase ids)
= (mkVarSet local_ids, RuleBase (mkVarSet imp_ids))
where
(local_ids, imp_ids) = partition (idIsFrom this_mod) (varSetElems ids)
pprRuleBase :: RuleBase -> SDoc
pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
\end{code}
......@@ -213,7 +213,7 @@ tcRnIface :: HscEnv
-> ModIface -- Get the decls from here
-> IO ModDetails
tcRnIface hsc_env iface
= initIfaceIO hsc_env (mi_deps iface) (typecheckIface iface)
= initIfaceTc hsc_env iface (typecheckIface iface)
\end{code}
......
......@@ -11,7 +11,7 @@ import TcRnTypes -- Re-export all
import IOEnv -- Re-export all
import HsSyn ( MonoBinds(..) )
import HscTypes ( HscEnv(..),
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
TyThing, Dependencies(..),
ExternalPackageState(..), HomePackageTable,
ModDetails(..), HomeModInfo(..),
......@@ -744,15 +744,38 @@ initIfaceExtCore thing_inside
}
; setEnvs (if_env, if_lenv) thing_inside }
initIfaceIO :: HscEnv -> Dependencies -> IfG a -> IO a
initIfaceIO hsc_env deps do_this
initIfaceCheck :: HscEnv -> IfG a -> IO a
-- Used when checking the up-to-date-ness of the old Iface
-- Initialise the environment with no useful info at all
initIfaceCheck hsc_env do_this
= do { let { gbl_env = IfGblEnv { if_is_boot = emptyModuleEnv,
if_rec_types = Nothing } ;
}
; initTcRnIf 'i' hsc_env gbl_env () do_this
}
initIfaceTc :: HscEnv -> ModIface -> IfG a -> IO a
-- Used when type-checking checking an up-to-date interface file
-- No type envt from the current module, but we do know the module dependencies
initIfaceTc hsc_env iface do_this
= do { let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)),
if_rec_types = Nothing } ;
}
; initTcRnIf 'i' hsc_env gbl_env () do_this
}
initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
-- Used when sucking in new Rules in SimplCore
-- We have available the type envt of the module being compiled, and we must use it
initIfaceRules hsc_env guts do_this
= do { let {
is_boot = mkModDeps (dep_mods deps)
is_boot = mkModDeps (dep_mods (mg_deps guts))
-- Urgh! But we do somehow need to get the info
-- on whether (for this particular compilation) we should
-- import a hi-boot file or not.
; type_info = (mg_module guts, return (mg_types guts))
; gbl_env = IfGblEnv { if_is_boot = is_boot,
if_rec_types = Nothing } ;
if_rec_types = Just type_info } ;
}
-- Run the thing; any exceptions just bubble out from here
......
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