X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FFamInst.lhs;h=e2e596f7768ef5ca5a828be39140d9e7fb000299;hp=41f22bed2639b4a2b484eba0468344f3dfaa4c96;hb=4287edeb7f329529149d8c95597d5e418388265f;hpb=366e8db02ab7a5bb5316699bff397d06e47891b2 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 $