FamInst.lhs 7.21 KB
 Simon Marlow committed Oct 11, 2006 1 The @FamInst@ type: family instance heads  chak@cse.unsw.edu.au. committed Sep 20, 2006 2 3 4  \begin{code} module FamInst (  chak@cse.unsw.edu.au. committed Oct 18, 2006 5  checkFamInstConsistency, tcExtendLocalFamInstEnv  chak@cse.unsw.edu.au. committed Sep 20, 2006 6 7 8 9  ) where #include "HsVersions.h"  Simon Marlow committed Oct 11, 2006 10 11 12 13 14 15 16 import HscTypes import FamInstEnv import TcMType import TcType import TcRnMonad import TyCon import Type  chak@cse.unsw.edu.au. committed Oct 12, 2006 17 import Name  chak@cse.unsw.edu.au. committed Oct 18, 2006 18 import Module  chak@cse.unsw.edu.au. committed Oct 12, 2006 19 import SrcLoc  chak@cse.unsw.edu.au. committed Sep 20, 2006 20 import Outputable  chak@cse.unsw.edu.au. committed Dec 07, 2006 21 import UniqFM  chak@cse.unsw.edu.au. committed Oct 18, 2006 22 import FiniteMap  chak@cse.unsw.edu.au. committed Oct 12, 2006 23   chak@cse.unsw.edu.au. committed Oct 18, 2006 24 import Maybe  chak@cse.unsw.edu.au. committed Oct 12, 2006 25 import Monad  chak@cse.unsw.edu.au. committed Sep 20, 2006 26 27 28 29 30 \end{code} %************************************************************************ %* *  chak@cse.unsw.edu.au. committed Oct 18, 2006 31  Optimised overlap checking for family instances  chak@cse.unsw.edu.au. committed Sep 20, 2006 32 33 34 %* * %************************************************************************  chak@cse.unsw.edu.au. committed Oct 18, 2006 35 36 37 38 39 40 41 42 43 44 45 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.)  chak@cse.unsw.edu.au. committed Sep 20, 2006 46 \begin{code}  chak@cse.unsw.edu.au. committed Oct 18, 2006 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 -- 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 ()  simonpj@microsoft.com committed May 02, 2007 68 listToSet :: [ModulePair] -> ModulePairSet  chak@cse.unsw.edu.au. committed Oct 18, 2006 69 70 71 72 73 74 75 76 77 78 79 80 81 82 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  chak@cse.unsw.edu.au. committed Dec 07, 2006 83 84 85 86 87 88 89 90  ; hmiModule = mi_module . hm_iface ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi) | hmi <- eltsUFM hpt] ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules extendModuleEnvList -- plus hptModInsts -- home package modules  chak@cse.unsw.edu.au. committed Oct 18, 2006 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106  ; 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  chak@cse.unsw.edu.au. committed Dec 07, 2006 107 108 109  -- The modules are guaranteed to be in the environment, as they are either -- already loaded in the EPS or they are in the HPT. --  chak@cse.unsw.edu.au. committed Oct 18, 2006 110 111 112 113 114 115 116 117 118 119 120 121 122 123  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 %* * %************************************************************************  chak@cse.unsw.edu.au. committed Sep 20, 2006 124   chak@cse.unsw.edu.au. committed Oct 18, 2006 125 \begin{code}  chak@cse.unsw.edu.au. committed Sep 20, 2006 126 127 128 129 130 -- Add new locally-defined family instances tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts  chak@cse.unsw.edu.au. committed Oct 10, 2006 131 132  ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env, tcg_fam_inst_env = inst_env' }  chak@cse.unsw.edu.au. committed Oct 18, 2006 133 134  ; setGblEnv env' thing_inside }  chak@cse.unsw.edu.au. committed Sep 20, 2006 135 136 137 138 139  -- 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  chak@cse.unsw.edu.au. committed Oct 18, 2006 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165  = 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  chak@cse.unsw.edu.au. committed Sep 20, 2006 166 167 168 169 170 171  -- 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.  chak@cse.unsw.edu.au. committed Oct 18, 2006 172 173 174 175 176  ; let { tycon = famInstTyCon famInst ; ty = case tyConFamInst_maybe tycon of Nothing -> panic "FamInst.checkForConflicts" Just (tc, tys) -> tc mkTyConApp tys }  simonpj@microsoft.com committed Nov 10, 2006 177  ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty  chak@cse.unsw.edu.au. committed Oct 18, 2006 178 179 180 181 182 183 184 185 186 187 188 189  ; 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) }  chak@cse.unsw.edu.au. committed Oct 12, 2006 190  where  chak@cse.unsw.edu.au. committed Oct 18, 2006 191  -- In the case of data/newtype instances, any overlap is a conflict (as  chak@cse.unsw.edu.au. committed Oct 12, 2006 192 193 194  -- these instances imply injective type mappings). conflicting _ _ tycon _ | isAlgTyCon tycon = True conflicting fam tys' tycon (subst, cFamInst) | otherwise =  chak@cse.unsw.edu.au. committed Oct 18, 2006 195  panic "FamInst.checkForConflicts: overlap check for indexed synonyms is still missing"  chak@cse.unsw.edu.au. committed Sep 20, 2006 196   chak@cse.unsw.edu.au. committed Oct 12, 2006 197 conflictInstErr famInst conflictingFamInst  chak@cse.unsw.edu.au. committed Sep 20, 2006 198  = addFamInstLoc famInst \$  chak@cse.unsw.edu.au. committed Oct 12, 2006 199 200  addErr (hang (ptext SLIT("Conflicting family instance declarations:")) 2 (pprFamInsts [famInst, conflictingFamInst]))  chak@cse.unsw.edu.au. committed Sep 20, 2006 201 202 203 204 205 206  addFamInstLoc famInst thing_inside = setSrcSpan (mkSrcSpan loc loc) thing_inside where loc = getSrcLoc famInst \end{code}`