From 7e7c11b2b285fd00758baac1be3784322a2aff62 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 13 Oct 2003 10:43:04 +0000 Subject: [PATCH] [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. --- ghc/compiler/iface/MkIface.lhs | 4 ++-- ghc/compiler/iface/TcIface.lhs | 12 ++++++----- ghc/compiler/simplCore/SimplCore.lhs | 35 ++++++++++++--------------------- ghc/compiler/specialise/Rules.lhs | 24 +++++++++++++++++++--- ghc/compiler/typecheck/TcRnDriver.lhs | 2 +- ghc/compiler/typecheck/TcRnMonad.lhs | 33 ++++++++++++++++++++++++++----- 6 files changed, 72 insertions(+), 38 deletions(-) diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 97cac77..235cf2a 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -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 } diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index aaedbac..dce075c 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -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 -> diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 1666fdf..5c39b9f 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -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]) diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 4f9c24d..7a2f320 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 29299a7..9a9e98b 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 0f615d8..b3bd086 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -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 -- 1.7.10.4