X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=7b7a9f483dd26b918f004be0940ad050ecdd9bba;hp=d688af9513cc63153ac6521c1625ed18f66e1ea8;hb=61f93d4611724685c5808bcfd41e3d3e0f3aa94f;hpb=cd450d41e84c2bf09bb9c3a646c7408eb2c2d772

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index d688af9..7b7a9f4 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -11,7 +11,7 @@ module TcSMonad (
     mkWantedConstraints, deCanonicaliseWanted, 
     makeGivens, makeSolvedByInst,
 
-    CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst, 
+    CtFlavor (..), isWanted, isGiven, isDerived, 
     isGivenCt, isWantedCt, pprFlavorArising,
 
     isFlexiTcsTv,
@@ -87,14 +87,11 @@ import InstEnv
 import FamInst 
 import FamInstEnv
 
-import NameSet ( addOneToNameSet ) 
-
 import qualified TcRnMonad as TcM
 import qualified TcMType as TcM
 import qualified TcEnv as TcM 
        ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
 import TcType
-import Module 
 import DynFlags
 
 import Coercion
@@ -300,9 +297,10 @@ data CtFlavor
                       --   these wanteds 
   | Wanted WantedLoc  -- We have no evidence bindings for this constraint. 
 
-data DerivedOrig = DerSC | DerInst 
+data DerivedOrig = DerSC | DerInst | DerSelf
 -- Deriveds are either superclasses of other wanteds or deriveds, or partially 
--- solved wanteds from instances. 
+-- solved wanteds from instances, or 'self' dictionaries containing yet wanted
+-- superclasses. 
 
 instance Outputable CtFlavor where 
   ppr (Given _)    = ptext (sLit "[Given]")
@@ -321,14 +319,6 @@ isDerived :: CtFlavor -> Bool
 isDerived (Derived {}) = True
 isDerived _            = False
 
-isDerivedSC :: CtFlavor -> Bool 
-isDerivedSC (Derived _ DerSC) = True 
-isDerivedSC _                 = False 
-
-isDerivedByInst :: CtFlavor -> Bool 
-isDerivedByInst (Derived _ DerInst) = True 
-isDerivedByInst _                   = False 
-
 pprFlavorArising :: CtFlavor -> SDoc
 pprFlavorArising (Derived wl _) = pprArisingAt wl
 pprFlavorArising (Wanted  wl)   = pprArisingAt wl
@@ -861,7 +851,7 @@ newDictVar cl tys = wrapTcS $ TcM.newDict cl tys
 
 
 \begin{code} 
-isGoodRecEv :: EvVar -> WantedEvVar -> TcS Bool 
+isGoodRecEv :: EvVar -> EvVar -> TcS Bool
 -- In a call (isGoodRecEv ev wv), we are considering solving wv 
 -- using some term that involves ev, such as:
 -- by setting		wv = ev
@@ -876,7 +866,7 @@ isGoodRecEv :: EvVar -> WantedEvVar -> TcS Bool
 -- call (constructor) and -1 for every superclass selection (destructor).
 --
 -- See Note [Superclasses and recursive dictionaries] in TcInteract
-isGoodRecEv ev_var (WantedEvVar wv _)
+isGoodRecEv ev_var wv
   = do { tc_evbinds <- getTcEvBindsBag 
        ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var 
        ; return $ case mb of 
@@ -896,16 +886,7 @@ isGoodRecEv ev_var (WantedEvVar wv _)
             | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig
             = chase_ev assocs trg curr_grav (orig:visited) ev_trm
 
-{-  No longer needed: evidence is in the EvBinds
-            | isTcTyVar orig && isMetaTyVar orig 
-            = do { meta_details <- wrapTcS $ TcM.readWantedCoVar orig
-                 ; case meta_details of 
-                     Flexi -> return Nothing 
-                     Indirect tyco -> chase_ev assocs trg curr_grav 
-                                             (orig:visited) (EvCoercion tyco)
-                           }
--}
-            | otherwise = return Nothing 
+            | otherwise = return Nothing
 
         chase_ev assocs trg curr_grav visited (EvId v) 
             = chase_ev_var assocs trg curr_grav visited v
@@ -918,9 +899,11 @@ isGoodRecEv ev_var (WantedEvVar wv _)
 
         chase_ev assocs trg curr_grav visited (EvCoercion co)
             = chase_co assocs trg curr_grav visited co
-        chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars) 
-            = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars
-                 ; return (comb_chase_res Nothing chase_results) } 
+        chase_ev assocs trg curr_grav visited (EvDFunApp _ _ _ev_vars ev_deps)
+            = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_deps
+                                    -- Notice that we chase the ev_deps and not the ev_vars
+                                    -- See Note [Dependencies in self dictionaries] in TcSimplify
+                 ; return (comb_chase_res Nothing chase_results) }
 
         chase_co assocs trg curr_grav visited co 
             = -- Look for all the coercion variables in the coercion 
@@ -966,8 +949,7 @@ matchClass clas tys
 				          text "witness" <+> ppr dfun_id
 					   <+> ppr (idType dfun_id) ])
 				  -- Record that this dfun is needed
-			; record_dfun_usage dfun_id
-			; return $ MatchInstSingle (dfun_id, inst_tys) 
+                        ; return $ MatchInstSingle (dfun_id, inst_tys)
                         } ;
      	    (matches, unifs)          -- More than one matches 
 		-> do	{ traceTcS "matchClass multiple matches, deferring choice"
@@ -978,26 +960,8 @@ matchClass clas tys
 		        }
 	}
         }
-  where record_dfun_usage :: Id -> TcS () 
-        record_dfun_usage dfun_id 
-          = do { hsc_env <- getTopEnv 
-               ; let  dfun_name = idName dfun_id
-        	      dfun_mod  = ASSERT( isExternalName dfun_name ) 
-        	         	  nameModule dfun_name
-               ; if isInternalName dfun_name ||    -- Internal name => defined in this module
-        	    modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
-        	 then return () -- internal, or in another package
-        	 else do updInstUses dfun_id 
-               }
-
-        updInstUses :: Id -> TcS () 
-        updInstUses dfun_id 
-            = do { tcg_env <- getGblEnv 
-                 ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env) 
-                                            (`addOneToNameSet` idName dfun_id) 
-                 }
-
-matchFam :: TyCon 
+
+matchFam :: TyCon
          -> [Type] 
          -> TcS (MatchInstResult (TyCon, [Type]))
 matchFam tycon args