SafeHaskell: Restrict OverlappingInstances.

OverlappingInstances in Safe modules can only overlap instances
defined in the same module.

11 files changed, 164 insertions, 98 deletions

diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 219ab6a917..b73c186dd0 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -240,7 +240,7 @@ loadInterface doc_str mod from
 
 	; ignore_prags      <- doptM Opt_IgnoreInterfacePragmas
 	; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)
-	; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
+	; new_eps_insts     <- mapM (tcIfaceInst $ mi_trust iface) (mi_insts iface)
 	; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
 	; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
 	; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 5bfb406c02..ac5794a53f 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -265,10 +265,10 @@ typecheckIface iface
 	; writeMutVar tc_env_var type_env
 
 		-- Now do those rules, instances and annotations
-	; insts     <- mapM tcIfaceInst    (mi_insts     iface)
+	; insts     <- mapM (tcIfaceInst $ mi_trust iface) (mi_insts iface)
 	; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
 	; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
-	; anns      <- tcIfaceAnnotations  (mi_anns iface)
+	; anns      <- tcIfaceAnnotations (mi_anns iface)
 
                 -- Vectorisation information
         ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env 
@@ -588,13 +588,14 @@ look at it.
 %************************************************************************
 
 \begin{code}
-tcIfaceInst :: IfaceInst -> IfL Instance
-tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
-			 ifInstCls = cls, ifInstTys = mb_tcs })
-  = do	{ dfun    <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
-		     tcIfaceExtId dfun_occ
-        ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
-	; return (mkImportedInstance cls mb_tcs' dfun oflag) }
+tcIfaceInst :: IfaceTrustInfo -> IfaceInst -> IfL Instance
+tcIfaceInst safe (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag,
+                              ifInstCls = cls, ifInstTys = mb_tcs })
+  = do { dfun    <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $
+                     tcIfaceExtId dfun_occ
+       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+       ; let safe' = getSafeMode safe
+       ; return (mkImportedInstance cls mb_tcs' dfun oflag safe') }
 
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
 tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, 
diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot
index c8ad717918..e6f3b7b0c4 100644
--- a/compiler/iface/TcIface.lhs-boot
+++ b/compiler/iface/TcIface.lhs-boot
@@ -1,20 +1,21 @@
 \begin{code}
 module TcIface where
-import IfaceSyn	  ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
-import TypeRep	  ( TyThing )
-import TcRnTypes  ( IfL )
-import InstEnv	  ( Instance )
-import FamInstEnv ( FamInst )
-import CoreSyn	  ( CoreRule )
-import HscTypes   ( TypeEnv, VectInfo, IfaceVectInfo )
-import Module     ( Module )
+
+import IfaceSyn    ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
+import TypeRep     ( TyThing )
+import TcRnTypes   ( IfL )
+import InstEnv     ( Instance )
+import FamInstEnv  ( FamInst )
+import CoreSyn     ( CoreRule )
+import HscTypes    ( TypeEnv, VectInfo, IfaceVectInfo, IfaceTrustInfo )
+import Module      ( Module )
 import Annotations ( Annotation )
 
-tcIfaceDecl    :: Bool -> IfaceDecl -> IfL TyThing
-tcIfaceRules   :: Bool -> [IfaceRule] -> IfL [CoreRule]
-tcIfaceVectInfo:: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
-tcIfaceInst    :: IfaceInst -> IfL Instance
-tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
+tcIfaceDecl        :: Bool -> IfaceDecl -> IfL TyThing
+tcIfaceRules       :: Bool -> [IfaceRule] -> IfL [CoreRule]
+tcIfaceVectInfo    :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
+tcIfaceInst        :: IfaceTrustInfo -> IfaceInst -> IfL Instance
+tcIfaceFamInst     :: IfaceFamInst -> IfL FamInst
 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
 \end{code}
 
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 378bbd607d..a3caea6e8e 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -13,8 +13,8 @@ module Inst (
 
        newOverloadedLit, mkOverLit, 
      
-       tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv,
-       instCallConstraints, newMethodFromName,
+       tcGetInstEnvs, getOverlapFlag, getSafeHaskellFlag,
+       tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
        tcSyntaxName,
 
        -- Simple functions over evidence variables
@@ -377,6 +377,11 @@ getOverlapFlag
 			   
 	; return overlap_flag }
 
+getSafeHaskellFlag :: TcM SafeHaskellMode
+getSafeHaskellFlag
+  = do { dflags <- getDOpts
+       ; return $ safeHaskell dflags }
+
 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 -- Gets both the external-package inst-env
 -- and the home-pkg inst env (includes module being compiled)
@@ -429,7 +434,7 @@ addLocalInst home_ie ispec
 		Nothing    -> return ()
 
 		-- Check for duplicate instance decls
-	; let { (matches, _) = lookupInstEnv inst_envs cls tys'
+	; let { (matches, _, _) = lookupInstEnv inst_envs cls tys'
 	      ;	dup_ispecs = [ dup_ispec 
 			     | (dup_ispec, _) <- matches
 			     , let (_,_,_,dup_tys) = instanceHead dup_ispec
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 995affdeaf..7499cd9ac6 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -315,13 +315,14 @@ tcDeriving tycl_decls inst_decls deriv_decls
         ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras
 
 	; overlap_flag <- getOverlapFlag
+	; safe <- getSafeHaskellFlag
 	; let (infer_specs, given_specs) = splitEithers early_specs
-	; insts1 <- mapM (genInst True overlap_flag) given_specs
+	; insts1 <- mapM (genInst True safe overlap_flag) given_specs
 
 	; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
-			 inferInstanceContexts overlap_flag infer_specs
+			 inferInstanceContexts safe overlap_flag infer_specs
 
-	; insts2 <- mapM (genInst False overlap_flag) final_specs
+	; insts2 <- mapM (genInst False safe overlap_flag) final_specs
 
 	-- We no longer generate the old generic to/from functions
         -- from each type declaration, so this is emptyBag
@@ -1324,11 +1325,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k,
 \end{itemize}
 
 \begin{code}
-inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
+inferInstanceContexts :: SafeHaskellMode -> OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
 
-inferInstanceContexts _ [] = return []
+inferInstanceContexts _ _ [] = return []
 
-inferInstanceContexts oflag infer_specs
+inferInstanceContexts safe oflag infer_specs
   = do	{ traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
 	; iterate_deriv 1 initial_solutions }
   where
@@ -1354,7 +1355,7 @@ inferInstanceContexts oflag infer_specs
       | otherwise
       =	do { 	  -- Extend the inst info from the explicit instance decls
 		  -- with the current set of solutions, and simplify each RHS
-	     let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
+	     let inst_specs = zipWithEqual "add_solns" (mkInstance safe oflag)
 					   current_solns infer_specs
 	   ; new_solns <- checkNoErrs $
 	     		  extendLocalInstEnv inst_specs $
@@ -1400,11 +1401,11 @@ inferInstanceContexts oflag infer_specs
         the_pred = mkClassPred clas inst_tys
 
 ------------------------------------------------------------------
-mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
-mkInstance overlap_flag theta
+mkInstance :: SafeHaskellMode -> OverlapFlag -> ThetaType -> DerivSpec -> Instance
+mkInstance safe overlap_flag theta
 	    (DS { ds_name = dfun_name
 		, ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
-  = mkLocalInstance dfun overlap_flag
+  = mkLocalInstance dfun overlap_flag safe
   where
     dfun = mkDictFunId dfun_name tyvars theta clas tys
 
@@ -1490,10 +1491,11 @@ the renamer.  What a great hack!
 -- Representation tycons differ from the tycon in the instance signature in
 -- case of instances for indexed families.
 --
-genInst :: Bool 	-- True <=> standalone deriving
-	-> OverlapFlag
+genInst :: Bool             -- True <=> standalone deriving
+        -> SafeHaskellMode
+        -> OverlapFlag
         -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
-genInst standalone_deriv oflag
+genInst standalone_deriv safe oflag
         spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
                  , ds_theta = theta, ds_newtype = is_newtype
                  , ds_name = name, ds_cls = clas })
@@ -1512,7 +1514,7 @@ genInst standalone_deriv oflag
                            , iBinds  = VanillaInst meth_binds [] standalone_deriv }
                  , aux_binds) }
   where
-    inst_spec = mkInstance oflag theta spec
+    inst_spec = mkInstance safe oflag theta spec
     co1 = case tyConFamilyCoercion_maybe rep_tycon of
               Just co_con -> mkAxInstCo co_con rep_tc_args
     	      Nothing     -> id_co
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index b199053ac2..29a98ac6fc 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -562,16 +562,17 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
            -- Note [Flattening in error message generation]
 
        ; case lookupInstEnv inst_envs clas tys_flat of
-                ([], _) -> return (Just pred)               -- No match
+                ([], _, _) -> return (Just pred)            -- No match
 		-- The case of exactly one match and no unifiers means a
 		-- successful lookup.  That can't happen here, because dicts
 		-- only end up here if they didn't match in Inst.lookupInst
-		([_],[])
+		([_],[], _)
 		 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
                 res          -> do { addErrorReport ctxt (mk_overlap_msg res)
                                    ; return Nothing } }
   where
-    mk_overlap_msg (matches, unifiers)
+    -- Normal overlap error
+    mk_overlap_msg (matches, unifiers, False)
       = ASSERT( not (null matches) )
         vcat [	addArising orig (ptext (sLit "Overlapping instances for") 
 				<+> pprPredTy pred)
@@ -600,33 +601,50 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
                                    vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
 			                  ptext (sLit "when compiling the other instance declarations")]
                               else empty])]
-      where
-    	ispecs = [ispec | (ispec, _) <- matches]
-
-        givens = getUserGivens ctxt
-        overlapping_givens = unifiable_givens givens
-
-        unifiable_givens [] = [] 
-        unifiable_givens (gg:ggs) 
-          | Just ggdoc <- matchable gg 
-          = ggdoc : unifiable_givens ggs 
-          | otherwise 
-          = unifiable_givens ggs 
-
-        matchable (evvars,gloc) 
-          = case ev_vars_matching of
-                 [] -> Nothing
-                 _  -> Just $ hang (pprTheta ev_vars_matching)
-                                2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
-                                       , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
-            where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
-                  ev_var_matches (ClassP clas' tys')
-                    | clas' == clas
-                    , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
-                    = True 
-                  ev_var_matches (ClassP clas' tys') =
-                    any ev_var_matches (immSuperClasses clas' tys')
-                  ev_var_matches _ = False
+        where
+            ispecs = [ispec | (ispec, _) <- matches]
+
+            givens = getUserGivens ctxt
+            overlapping_givens = unifiable_givens givens
+    
+            unifiable_givens [] = [] 
+            unifiable_givens (gg:ggs) 
+              | Just ggdoc <- matchable gg 
+              = ggdoc : unifiable_givens ggs 
+              | otherwise 
+              = unifiable_givens ggs 
+    
+            matchable (evvars,gloc) 
+              = case ev_vars_matching of
+                     [] -> Nothing
+                     _  -> Just $ hang (pprTheta ev_vars_matching)
+                                    2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+                                           , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+                where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+                      ev_var_matches (ClassP clas' tys')
+                        | clas' == clas
+                        , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+                        = True 
+                      ev_var_matches (ClassP clas' tys') =
+                        any ev_var_matches (immSuperClasses clas' tys')
+                      ev_var_matches _ = False
+
+    -- Overlap error because of SafeHaskell (first match should be the most
+    -- specific match)
+    mk_overlap_msg (matches, unifiers, True)
+      = ASSERT( length matches > 1 )
+        vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") 
+                        <+> pprPred pred)
+             , sep [ptext (sLit "The matching instance is") <> colon,
+                    nest 2 (pprInstance $ head ispecs)]
+             , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only"
+                    , ptext $ sLit "overlap instances from the same module, however it"
+                    , ptext $ sLit "overlaps the following instances from different modules:"
+                    , nest 2 (vcat [pprInstances $ tail ispecs])
+                    ]
+             ]
+        where
+            ispecs = [ispec | (ispec, _) <- matches]
 
 
 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index d4d8d2fbc5..7ca7a327ad 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -450,10 +450,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
 		-- Dfun location is that of instance *header*
         ; overlap_flag <- getOverlapFlag
+        ; safe <- getSafeHaskellFlag
         ; let (eq_theta,dict_theta) = partition isEqPred theta
               theta'         = eq_theta ++ dict_theta
               dfun           = mkDictFunId dfun_name tyvars theta' clas inst_tys
-              ispec          = mkLocalInstance dfun overlap_flag
+              ispec          = mkLocalInstance dfun overlap_flag safe
 
         ; return (InstInfo { iSpec  = ispec, iBinds = VanillaInst binds uprags False },
                   idx_tycons)
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 0992fb971e..39f3c4b216 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -916,13 +916,13 @@ matchClass clas tys
   = do	{ let pred = mkClassPred clas tys 
         ; instEnvs <- getInstEnvs
         ; case lookupInstEnv instEnvs clas tys of {
-            ([], unifs)               -- Nothing matches  
+            ([], unifs, _)               -- Nothing matches  
                 -> do { traceTcS "matchClass not matching"
                                  (vcat [ text "dict" <+> ppr pred, 
                                          text "unifs" <+> ppr unifs ]) 
                       ; return MatchInstNo  
                       } ;  
-	    ([(ispec, inst_tys)], []) -- A single match 
+	    ([(ispec, inst_tys)], [], _) -- A single match 
 		-> do	{ let dfun_id = is_dfun ispec
 			; traceTcS "matchClass success"
 				   (vcat [text "dict" <+> ppr pred, 
@@ -931,7 +931,7 @@ matchClass clas tys
 				  -- Record that this dfun is needed
                         ; return $ MatchInstSingle (dfun_id, inst_tys)
                         } ;
-     	    (matches, unifs)          -- More than one matches 
+     	    (matches, unifs, _)          -- More than one matches 
 		-> do	{ traceTcS "matchClass multiple matches, deferring choice"
 			           (vcat [text "dict" <+> ppr pred,
 				   	  text "matches" <+> ppr matches,
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 6da5741037..97ad485e6a 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -970,7 +970,7 @@ lookupClassInstances c ts
 
 	-- Now look up instances
         ; inst_envs <- tcGetInstEnvs
-        ; let (matches, unifies) = lookupInstEnv inst_envs cls tys
+        ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys
         ; mapM reifyClassInstance (map fst matches ++ unifies) } } }
   where
     doc = ptext (sLit "TcSplice.classInstances")
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 7a2a65e06b..4fb64fb473 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -21,6 +21,7 @@ module InstEnv (
 
 #include "HsVersions.h"
 
+import DynFlags
 import Class
 import Var
 import VarSet
@@ -46,21 +47,23 @@ import Data.Maybe	( isJust, isNothing )
 
 \begin{code}
 data Instance 
-  = Instance { is_cls  :: Name		-- Class name
-	
-		-- Used for "rough matching"; see Note [Rough-match field]
-		-- INVARIANT: is_tcs = roughMatchTcs is_tys
-	     , is_tcs  :: [Maybe Name]	-- Top of type args
-
-		-- Used for "proper matching"; see Note [Proper-match fields]
-	     , is_tvs  :: TyVarSet	-- Template tyvars for full match
-	     , is_tys  :: [Type]	-- Full arg types
-		-- INVARIANT: is_dfun Id has type 
-		--	forall is_tvs. (...) => is_cls is_tys
-
-	     , is_dfun :: DFunId -- See Note [Haddock assumptions]
-	     , is_flag :: OverlapFlag	-- See detailed comments with
-					-- the decl of BasicTypes.OverlapFlag
+  = Instance { is_cls  :: Name  -- Class name
+
+                -- Used for "rough matching"; see Note [Rough-match field]
+                -- INVARIANT: is_tcs = roughMatchTcs is_tys
+             , is_tcs  :: [Maybe Name]  -- Top of type args
+
+                -- Used for "proper matching"; see Note [Proper-match fields]
+             , is_tvs  :: TyVarSet      -- Template tyvars for full match
+             , is_tys  :: [Type]        -- Full arg types
+                -- INVARIANT: is_dfun Id has type 
+                --      forall is_tvs. (...) => is_cls is_tys
+
+             , is_dfun :: DFunId -- See Note [Haddock assumptions]
+             , is_flag :: OverlapFlag   -- See detailed comments with
+                                        -- the decl of BasicTypes.OverlapFlag
+             , is_safe :: SafeHaskellMode -- SafeHaskell mode of module the
+                                          -- instance came from
     }
 \end{code}
 
@@ -177,21 +180,22 @@ instanceHead ispec
 
 mkLocalInstance :: DFunId
                 -> OverlapFlag
+                -> SafeHaskellMode
                 -> Instance
 -- Used for local instances, where we can safely pull on the DFunId
-mkLocalInstance dfun oflag
-  = Instance {	is_flag = oflag, is_dfun = dfun,
+mkLocalInstance dfun oflag sflag
+  = Instance {	is_flag = oflag, is_safe = sflag, is_dfun = dfun,
 		is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = className cls, is_tcs = roughMatchTcs tys }
   where
     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
 mkImportedInstance :: Name -> [Maybe Name]
-		   -> DFunId -> OverlapFlag -> Instance
+		   -> DFunId -> OverlapFlag -> SafeHaskellMode -> Instance
 -- Used for imported instances, where we get the rough-match stuff
 -- from the interface file
-mkImportedInstance cls mb_tcs dfun oflag
-  = Instance {	is_flag = oflag, is_dfun = dfun,
+mkImportedInstance cls mb_tcs dfun oflag sflag
+  = Instance {	is_flag = oflag, is_safe = sflag, is_dfun = dfun,
 		is_tvs = mkVarSet tvs, is_tys = tys,
 		is_cls = cls, is_tcs = mb_tcs }
   where
@@ -437,7 +441,9 @@ where the Nothing indicates that 'b' can be freely instantiated.
 lookupInstEnv :: (InstEnv, InstEnv) 	-- External and home package inst-env
 	      -> Class -> [Type]	-- What we are looking for
 	      -> ([InstMatch], 		-- Successful matches
-		  [Instance])		-- These don't match but do unify
+		  [Instance],		-- These don't match but do unify
+                  Bool)                 -- True if error condition caused by
+                                        -- SafeHaskell condition.
 
 -- The second component of the result pair happens when we look up
 --	Foo [a]
@@ -450,7 +456,7 @@ lookupInstEnv :: (InstEnv, InstEnv) 	-- External and home package inst-env
 -- giving a suitable error messagen
 
 lookupInstEnv (pkg_ie, home_ie) cls tys
-  = (pruned_matches, all_unifs)
+  = (safe_matches, all_unifs, safe_fail)
   where
     rough_tcs  = roughMatchTcs tys
     all_tvs    = all isNothing rough_tcs
@@ -459,11 +465,43 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
     all_matches = home_matches ++ pkg_matches
     all_unifs   = home_unifs   ++ pkg_unifs
     pruned_matches = foldr insert_overlapping [] all_matches
+    (safe_matches, safe_fail) = if length pruned_matches /= 1 
+                        then (pruned_matches, False)
+                        else check_safe (head pruned_matches) all_matches
 	-- Even if the unifs is non-empty (an error situation)
 	-- we still prune the matches, so that the error message isn't
 	-- misleading (complaining of multiple matches when some should be
 	-- overlapped away)
 
+    -- SafeHaskell: We restrict code compiled in 'Safe' mode from 
+    -- overriding code compiled in any other mode. The rational is
+    -- that code compiled in 'Safe' mode is code that is untrusted
+    -- by the ghc user. So we shouldn't let that code change the
+    -- behaviour of code the user didn't compile in 'Safe' mode
+    -- since thats the code they trust. So 'Safe' instances can only
+    -- overlap instances from the same module. A same instance origin
+    -- policy for safe compiled instances.
+    check_safe match@(inst,_) others
+        = case is_safe inst of
+                -- most specific isn't from a Safe module so OK
+                sf | sf /= Sf_Safe && sf /= Sf_SafeLanguage -> ([match], True)
+                -- otherwise we make sure it only overlaps instances from
+                -- the same module
+                _other -> (go [] others, True)
+        where
+            go bad [] = match:bad
+            go bad (i@(x,_):unchecked) =
+                if inSameMod x
+                    then go bad unchecked
+                    else go (i:bad) unchecked
+            
+            inSameMod b =
+                let na = getName $ getName inst
+                    la = isInternalName na
+                    nb = getName $ getName b
+                    lb = isInternalName nb
+                in (la && lb) || (nameModule na == nameModule nb)
+
     --------------
     lookup env = case lookupUFM env cls of
 		   Nothing -> ([],[])	-- No instances for this class
diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
index 2fc94d8f4a..9492f1010f 100644
--- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs
+++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
@@ -38,7 +38,7 @@ lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
 lookupInst cls tys
   = do { instEnv <- getInstEnv
        ; case lookupInstEnv instEnv cls tys of
-	   ([(inst, inst_tys)], _) 
+	   ([(inst, inst_tys)], _, _) 
              | noFlexiVar -> return (instanceDFunId inst, inst_tys')
              | otherwise  -> pprPanic "VectMonad.lookupInst: flexi var: " 
                                       (ppr $ mkTyConApp (classTyCon cls) tys)