import TcRnTypes ( ImportAvails(..), mkModDeps )
import HscTypes ( ModIface(..),
ModGuts(..), ModGuts, IfaceExport,
- GhciMode(..), noDependencies,
+ GhciMode(..),
HscEnv(..), hscEPS,
Dependencies(..), FixItem(..),
isImplicitTyThing,
= 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
}
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 )
(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 ->
)
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 )
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 )
[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])
module Rules (
RuleBase, emptyRuleBase,
extendRuleBase, extendRuleBaseList,
- ruleBaseIds,
+ ruleBaseIds, getLocalRules,
pprRuleBase, ruleCheckProgram,
lookupRule, addRule, addIdSpecialisations
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}
-- 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}
-> 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}
import IOEnv -- Re-export all
import HsSyn ( MonoBinds(..) )
-import HscTypes ( HscEnv(..),
+import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
TyThing, Dependencies(..),
ExternalPackageState(..), HomePackageTable,
ModDetails(..), HomeModInfo(..),
}
; 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
projects / ghc-hetmet.git / commitdiff