X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FFamInst.lhs;h=ccdbf579dcadf662509654061fb67b86a64e2aab;hp=68c409655dba9609fea130c96f010e9c2dd4c27e;hb=HEAD;hpb=91923f12046713b115003e184f7098ee00c00028

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 68c4096..ccdbf57 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -1,91 +1,209 @@
-\section[FamInst]{The @FamInst@ type: family instance heads}
+The @FamInst@ type: family instance heads
 
 \begin{code}
 module FamInst ( 
-        tcExtendLocalFamInstEnv
+        checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs
     ) where
 
-#include "HsVersions.h"
-
-import FamInstEnv ( FamInstEnv, FamInst(..), famInstTyCon, extendFamInstEnv,
-		    pprFamInst, pprFamInsts )
-import TcMType	  ( tcInstSkolType )
-import TcType	  ( SkolemInfo(..), tcSplitTyConApp )
-import TcRnMonad  ( TcM, TcGblEnv(..), setGblEnv, getGblEnv, foldlM,
-		    setSrcSpan, addErr )
-import TyCon      ( tyConFamInst_maybe )
-import Type	  ( mkTyConApp )
-import Name	  ( getSrcLoc )
-import SrcLoc	  ( mkSrcSpan )
+import HscTypes
+import FamInstEnv
+import LoadIface
+import TcMType
+import TcRnMonad
+import TyCon
+import Name
+import Module
+import SrcLoc
 import Outputable
+import UniqFM
+import FastString
+
+import Maybes
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
 \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.
+
+Why do we need to check?  Consider 
+   module X1 where	  	  module X2 where
+    data T1			    data T2
+    type instance F T1 b = Int	    type instance F a T2 = Char
+    f1 :: F T1 a -> Int		    f2 :: Char -> F a T2
+    f1 x = x			    f2 x = x
+
+Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
+Notice that neither instance is an orphan.
+
+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 = Map ModulePair ()
+
+listToSet :: [ModulePair] -> ModulePairSet
+listToSet l = Map.fromList (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 directly 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
+
+             ; hmiModule     = mi_module . hm_iface
+	     ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv 
+                               . md_fam_insts . hm_details
+             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) 
+			                   | hmi <- eltsUFM hpt]
+	     ; 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  = Map.keys $ criticalPairs `Map.difference` okPairs
+	         -- the difference gives us the pairs we need to check now
+	     }
+
+       ; mapM_ (check hpt_fam_insts) toCheckPairs
+       }
+  where
+    allPairs []     = []
+    allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
+
+    check hpt_fam_insts (ModulePair m1 m2)
+      = do { env1 <- getFamInsts hpt_fam_insts m1
+           ; env2 <- getFamInsts hpt_fam_insts m2
+           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))   
+                   (famInstEnvElts env1) }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+                   ; eps <- getEps
+                   ; return (expectJust "checkFamInstConsistency" $
+                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+  where
+    doc = ppr mod <+> ptext (sLit "is a family-instance module")
+\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
  = do { env <- getGblEnv
       ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts
-      ; let env' = env { tcg_fam_inst_env = inst_env' }
-      ; setGblEnv env' thing_inside }
-
+      ; let env' = env { tcg_fam_insts    = fam_insts ++ tcg_fam_insts env,
+			 tcg_fam_inst_env = inst_env' }
+      ; 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	{ 	-- 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', theta', tau') <- tcInstSkolType (FamInstSkol tycon) ty
-
-	; let	(fam, tys') = tcSplitTyConApp tau'
-
-{- !!!TODO: Need to complete this:
-		-- Load imported instances, so that we report
-		-- overlaps correctly
-	; eps <- getEps
-	; let inst_envs = (eps_fam_inst_env eps, home_fie)
-
-		-- Check for overlapping instance decls
-	; let { (matches, _) = lookupFamInstEnv inst_envs fam tys'
-	      ;	dup_ispecs = [ dup_ispec   --!!!adapt
-			     | (_, dup_ispec) <- matches
-			     , let (_,_,_,dup_tys) = instanceHead dup_ispec
-			     , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
-		-- Find memebers of the match list which ispec itself matches.
-		-- If the match is 2-way, it's a duplicate
-	; case dup_ispecs of
-	    dup_ispec : _ -> dupInstErr famInst dup_ispec
-	    []            -> return ()
- -}
-
-		-- OK, now extend the envt
-	; return (extendFamInstEnv home_fie famInst) }
-
-overlapErr famInst dupFamInst
+
+       ; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))
+       ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
+       ; unless (null conflicts) $
+	   conflictInstErr famInst (fst (head conflicts))
+       }
+  where
+
+conflictInstErr :: FamInst -> FamInst -> TcRn ()
+conflictInstErr famInst conflictingFamInst
   = addFamInstLoc famInst $
-    addErr (hang (ptext SLIT("Overlapping family instance declarations:"))
-	       2 (pprFamInsts [famInst, dupFamInst]))
+    addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
+	       2 (pprFamInsts [famInst, conflictingFamInst]))
 
+addFamInstLoc :: FamInst -> TcRn a -> TcRn a
 addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
     loc = getSrcLoc famInst
+
+tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetFamInstEnvs 
+  = do { eps <- getEps; env <- getGblEnv
+       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
 \end{code}