From: Manuel M T Chakravarty Date: Wed, 18 Oct 2006 22:13:00 +0000 (+0000) Subject: Cross-module consistency check for family instances X-Git-Tag: 2006-10-22~8 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=4287edeb7f329529149d8c95597d5e418388265f Cross-module consistency check for family instances --- diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index fce5c1d..0d9feb4 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -238,9 +238,12 @@ loadInterface doc_str mod from ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) - ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", - mi_insts = panic "No mi_insts in PIT", - mi_rules = panic "No mi_rules in PIT" } } + ; let { final_iface = iface { + mi_decls = panic "No mi_decls in PIT", + mi_insts = panic "No mi_insts in PIT", + mi_fam_insts = panic "No mi_fam_insts in PIT", + mi_rules = panic "No mi_rules in PIT" + } } ; updateEps_ $ \ eps -> eps { @@ -252,6 +255,15 @@ loadInterface doc_str mod from new_eps_insts, eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) new_eps_fam_insts, + eps_mod_fam_inst_env + = let + fam_inst_env = + extendFamInstEnvList emptyFamInstEnv + new_eps_fam_insts + in + extendModuleEnv (eps_mod_fam_inst_env eps) + mod + fam_inst_env, eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) (length new_eps_insts) (length new_eps_rules) } @@ -456,6 +468,8 @@ initExternalPackageState eps_fam_inst_env = emptyFamInstEnv, eps_rule_base = mkRuleBase builtinRules, -- Initialise the EPS rule pool with the built-in rules + eps_mod_fam_inst_env + = emptyModuleEnv, eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0 , n_rules_in = length builtinRules, n_rules_out = 0 } diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 8e064bc..c5483b9 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -440,12 +440,12 @@ data ModIface -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails = ModDetails { - -- The next three fields are created by the typechecker - md_exports :: [AvailInfo], - md_types :: !TypeEnv, - md_fam_insts :: ![FamInst], -- Cached value extracted from md_types - md_insts :: ![Instance], -- Dfun-ids for the instances in this module - md_rules :: ![CoreRule] -- Domain may include Ids from other modules + -- The next two fields are created by the typechecker + md_exports :: [AvailInfo], + md_types :: !TypeEnv, + md_insts :: ![Instance], -- Dfun-ids for the instances in this module + md_fam_insts :: ![FamInst], + md_rules :: ![CoreRule] -- Domain may include Ids from other modules } emptyModDetails = ModDetails { md_types = emptyTypeEnv, @@ -1008,6 +1008,9 @@ data ExternalPackageState eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- identifies family + -- instances of each mod + eps_stats :: !EpsStats } diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 41f22be..e2e596f 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -2,7 +2,7 @@ The @FamInst@ type: family instance heads \begin{code} module FamInst ( - tcExtendLocalFamInstEnv + checkFamInstConsistency, tcExtendLocalFamInstEnv ) where #include "HsVersions.h" @@ -15,21 +15,103 @@ import TcRnMonad import TyCon import Type import Name +import Module import SrcLoc import Outputable +import FiniteMap +import Maybe import Monad \end{code} %************************************************************************ %* * - Extending the family instance environment + Optimised overlap checking for family instances %* * %************************************************************************ +For any two family instance modules that we import directly or indirectly, we +check whether the instances in the two modules are consistent, *unless* we can +be certain that the instances of the two modules have already been checked for +consistency during the compilation of modules that we import. + +How do we know which pairs of modules have already been checked? Any pair of +modules where both modules occur in the `HscTypes.dep_finsts' set (of the +`HscTypes.Dependencies') of one of our directly imported modules must have +already been checked. Everything else, we check now. (So that we can be +certain that the modules in our `HscTypes.dep_finsts' are consistent.) + \begin{code} +-- The optimisation of overlap tests is based on determining pairs of modules +-- whose family instances need to be checked for consistency. +-- +data ModulePair = ModulePair Module Module + +-- canonical order of the components of a module pair +-- +canon :: ModulePair -> (Module, Module) +canon (ModulePair m1 m2) | m1 < m2 = (m1, m2) + | otherwise = (m2, m1) + +instance Eq ModulePair where + mp1 == mp2 = canon mp1 == canon mp2 + +instance Ord ModulePair where + mp1 `compare` mp2 = canon mp1 `compare` canon mp2 + +-- Sets of module pairs +-- +type ModulePairSet = FiniteMap ModulePair () + +listToSet l = listToFM (zip l (repeat ())) + +checkFamInstConsistency :: [Module] -> [Module] -> TcM () +checkFamInstConsistency famInstMods directlyImpMods + = do { dflags <- getDOpts + ; (eps, hpt) <- getEpsAndHpt + + ; let { -- Fetch the iface of a given module. Must succeed as + -- all imported modules must already have been loaded. + modIface mod = + case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of + Nothing -> panic "FamInst.checkFamInstConsistency" + Just iface -> iface + + ; modInstsEnv = eps_mod_fam_inst_env eps + ; groups = map (dep_finsts . mi_deps . modIface) + directlyImpMods + ; okPairs = listToSet $ concatMap allPairs groups + -- instances of okPairs are consistent + ; criticalPairs = listToSet $ allPairs famInstMods + -- all pairs that we need to consider + ; toCheckPairs = keysFM $ criticalPairs `minusFM` okPairs + -- the difference gives us the pairs we need to check now + } + + ; mapM_ (check modInstsEnv) toCheckPairs + } + where + allPairs [] = [] + allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms + + -- Check the consistency of the family instances of the two modules. + check modInstsEnv (ModulePair m1 m2) + = let { instEnv1 = fromJust . lookupModuleEnv modInstsEnv $ m1 + ; instEnv2 = fromJust . lookupModuleEnv modInstsEnv $ m2 + ; insts1 = famInstEnvElts instEnv1 + } + in + mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1 +\end{code} + +%************************************************************************ +%* * + Extending the family instance environment +%* * +%************************************************************************ +\begin{code} -- Add new locally-defined family instances tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside @@ -37,52 +119,69 @@ tcExtendLocalFamInstEnv fam_insts thing_inside ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env, tcg_fam_inst_env = inst_env' } - ; setGblEnv env' thing_inside } - + ; setGblEnv env' thing_inside + } -- Check that the proposed new instance is OK, -- and then add it to the home inst env addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv addLocalFamInst home_fie famInst - = do { -- To instantiate the family instance type, extend the instance + = do { -- Load imported instances, so that we report + -- overlaps correctly + ; eps <- getEps + ; let inst_envs = (eps_fam_inst_env eps, home_fie) + + -- Check for conflicting instance decls + ; checkForConflicts inst_envs famInst + + -- OK, now extend the envt + ; return (extendFamInstEnv home_fie famInst) + } +\end{code} + +%************************************************************************ +%* * + Checking an instance against conflicts with an instance env +%* * +%************************************************************************ + +Check whether a single family instance conflicts with those in two instance +environments (one for the EPS and one for the HPT). + +\begin{code} +checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM () +checkForConflicts inst_envs famInst + = do { -- To instantiate the family instance type, extend the instance -- envt with completely fresh template variables -- This is important because the template variables must -- not overlap with anything in the things being looked up -- (since we do unification). -- We use tcInstSkolType because we don't want to allocate -- fresh *meta* type variables. - let tycon = famInstTyCon famInst - ty = case tyConFamInst_maybe tycon of - Nothing -> panic "FamInst.addLocalFamInst" - Just (tc, tys) -> tc `mkTyConApp` tys - ; (tvs', _, tau') <- tcInstSkolType (FamInstSkol tycon) ty - - ; let (fam, tys') = tcSplitTyConApp tau' - - -- Load imported instances, so that we report - -- overlaps correctly - ; eps <- getEps - ; let inst_envs = (eps_fam_inst_env eps, home_fie) - - -- Check for conflicting instance decls - ; let { matches = lookupFamInstEnvUnify inst_envs fam tys' - ; conflicts = [ conflictingFamInst - | match@(_, conflictingFamInst) <- matches - , conflicting fam tys' tycon match - ] - } - ; unless (null conflicts) $ - conflictInstErr famInst (head conflicts) - - -- OK, now extend the envt - ; return (extendFamInstEnv home_fie famInst) - } + ; let { tycon = famInstTyCon famInst + ; ty = case tyConFamInst_maybe tycon of + Nothing -> panic "FamInst.checkForConflicts" + Just (tc, tys) -> tc `mkTyConApp` tys + } + ; (tvs', _, tau') <- tcInstSkolType (FamInstSkol tycon) ty + + ; let (fam, tys') = tcSplitTyConApp tau' + + ; let { matches = lookupFamInstEnvUnify inst_envs fam tys' + ; conflicts = [ conflictingFamInst + | match@(_, conflictingFamInst) <- matches + , conflicting fam tys' tycon match + ] + } + ; unless (null conflicts) $ + conflictInstErr famInst (head conflicts) + } where - -- In the case of data/newtype instances, any overlap is a conflicts (as + -- In the case of data/newtype instances, any overlap is a conflict (as -- these instances imply injective type mappings). conflicting _ _ tycon _ | isAlgTyCon tycon = True conflicting fam tys' tycon (subst, cFamInst) | otherwise = - panic "FamInst.addLocalFamInst: overlap check for indexed synonyms is still missing" + panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing" conflictInstErr famInst conflictingFamInst = addFamInstLoc famInst $ diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 94c55a7..696e41b 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -37,6 +37,7 @@ import TcExpr import TcRnMonad import TcType import Inst +import FamInst import InstEnv import FamInstEnv import TcBinds @@ -173,6 +174,12 @@ tcRnModule hsc_env hsc_src save_rn_syntax loadOrphanModules (imp_orphs imports) False ; loadOrphanModules (imp_finsts imports) True ; + let { directlyImpMods = map (\(mod, _, _) -> mod) + . moduleEnvElts + . imp_mods + $ imports } ; + checkFamInstConsistency (imp_finsts imports) directlyImpMods ; + traceRn (text "rn1a") ; -- Rename and type check the declarations tcg_env <- if isHsBoot hsc_src then diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index b335b54..37f1eab 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -469,7 +469,8 @@ of whether the imported things are actually used or not It is used * when processing the export list * when constructing usage info for the inteface file * to identify the list of directly imported modules - for initialisation purposes + for initialisation purposes and + for optimsed overlap checking of family instances * when figuring out what things are really unused \begin{code}