Merge branch 'master' into type-nats
[ghc.git] / compiler / typecheck / TcSMonad.lhs
index 3d8163d..c7c667e 100644 (file)
@@ -5,53 +5,59 @@ module TcSMonad (
        -- Canonical constraints
     CanonicalCts, emptyCCan, andCCan, andCCans, 
     singleCCan, extendCCans, isEmptyCCan, isCTyEqCan, 
-    isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, 
+    isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
+    isCFrozenErr,
+
+    WorkList, unionWorkList, unionWorkLists, isEmptyWorkList, emptyWorkList,
+    workListFromEq, workListFromNonEq,
+    workListFromEqs, workListFromNonEqs, foldrWorkListM,
 
     CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, 
-    mkWantedConstraints, deCanonicaliseWanted, 
-    makeGivens, makeSolvedByInst,
+    deCanonicalise, mkFrozenError,
+
+    isWanted, isGivenOrSolved, isDerived,
+    isGivenOrSolvedCt, isGivenCt_maybe, 
+    isWantedCt, isDerivedCt, pprFlavorArising,
 
-    CtFlavor (..), isWanted, isGiven, isDerived, isDerivedSC, isDerivedByInst, 
-    isGivenCt, isWantedCt, 
+    isFlexiTcsTv,
 
-    DerivedOrig (..), 
     canRewrite, canSolve,
-    combineCtLoc, mkGivenFlavor,
+    combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
+    mkWantedFlavor,
+    getWantedLoc,
 
-    TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0,  -- Basic functionality 
+    TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality 
+    traceFireTcS, bumpStepCountTcS,
     tryTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS,
     SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,
-       
-       -- Creation of evidence variables
 
-    newWantedCoVar, newGivOrDerCoVar, newGivOrDerEvVar, 
+       -- Creation of evidence variables
+    newEvVar, newCoVar, newGivenCoVar,
+    newDerivedId, 
     newIPVar, newDictVar, newKindConstraint,
 
        -- Setting evidence variables 
-    setWantedCoBind, setDerivedCoBind, 
-    setIPBind, setDictBind, setEvBind,
+    setCoBind, setIPBind, setDictBind, setEvBind,
 
     setWantedTyBind,
 
-    newTcEvBindsTcS,
-    getInstEnvs, getFamInstEnvs,                -- Getting the environments 
+    lookupFlatCacheMap, updateFlatCacheMap,
+
+    getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
+    tcsLookupClass, tcsLookupTyCon,
     getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
 
-
     newFlattenSkolemTy,                         -- Flatten skolems 
 
 
     instDFunTypes,                              -- Instantiation
-    instDFunConstraints,                        
-
-    isGoodRecEv,
+    instDFunConstraints,          
+    newFlexiTcSTy, instFlexiTcS,
 
-    zonkTcTypeTcS,                              -- Zonk through the TyBinds of the Tcs Monad
     compatKind,
 
-
+    TcsUntouchables,
     isTouchableMetaTyVar,
     isTouchableMetaTyVar_InRange, 
 
@@ -60,15 +66,11 @@ module TcSMonad (
     matchClass, matchFam, MatchInstResult (..), 
     checkWellStagedDFun, 
     warnTcS,
-    pprEq,                                   -- Smaller utils, re-exported from TcM 
+    pprEq                                   -- Smaller utils, re-exported from TcM 
                                              -- TODO (DV): these are only really used in the 
                                              -- instance matcher in TcSimplify. I am wondering
                                              -- if the whole instance matcher simply belongs
                                              -- here 
-
-
-    mkWantedFunDepEqns                       -- Instantiation of 'Equations' from FunDeps
-
 ) where 
 
 #include "HsVersions.h"
@@ -81,14 +83,13 @@ 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 )
+       ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys
+       , tcLookupClass, tcLookupTyCon )
+import Kind
 import TcType
-import Module 
 import DynFlags
 
 import Coercion
@@ -103,15 +104,20 @@ import Outputable
 import Bag
 import MonadUtils
 import VarSet
+import Pair
 import FastString
 
 import HsBinds               -- for TcEvBinds stuff 
 import Id 
-import FunDeps
-
 import TcRnTypes
-
 import Data.IORef
+
+import qualified Data.Map as Map
+
+#ifdef DEBUG
+import StaticFlags( opt_PprStyle_Debug )
+import Control.Monad( when )
+#endif
 \end{code}
 
 
@@ -152,13 +158,9 @@ data CanonicalCt
   | CTyEqCan {  -- tv ~ xi     (recall xi means function free)
        -- Invariant: 
        --   * tv not in tvs(xi)   (occurs check)
-       --   * If constraint is given then typeKind xi `compatKind` typeKind tv 
-       --                See Note [Spontaneous solving and kind compatibility] 
-       --   * If 'xi' is a flatten skolem then 'tv' can only be: 
-       --              - a flatten skolem or a unification variable
-       --     i.e. equalities prefer flatten skolems in their LHS 
-       --     See Note [Loopy Spontaneous Solving, Example 4]
-       --     Also related to [Flatten Skolem Equivalence Classes]
+       --   * typeKind xi `compatKind` typeKind tv
+       --       See Note [Spontaneous solving and kind compatibility]
+       --   * We prefer unification variables on the left *JUST* for efficiency
       cc_id     :: EvVar, 
       cc_flavor :: CtFlavor, 
       cc_tyvar  :: TcTyVar, 
@@ -167,10 +169,7 @@ data CanonicalCt
 
   | CFunEqCan {  -- F xis ~ xi  
                  -- Invariant: * isSynFamilyTyCon cc_fun 
-                 --            * cc_rhs is not a touchable unification variable 
-                 --                   See Note [No touchables as FunEq RHS]
-                 --            * If constraint is given then 
-                 --                 typeKind (TyConApp cc_fun cc_tyargs) `compatKind` typeKind cc_rhs
+                 --            * typeKind (F xis) `compatKind` typeKind xi
       cc_id     :: EvVar,
       cc_flavor :: CtFlavor, 
       cc_fun    :: TyCon,      -- A type function
@@ -180,37 +179,27 @@ data CanonicalCt
                    
     }
 
-compatKind :: Kind -> Kind -> Bool 
+  | CFrozenErr {      -- A "frozen error" does not interact with anything
+                      -- See Note [Frozen Errors]
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor
+    }
+
+mkFrozenError :: CtFlavor -> EvVar -> CanonicalCt
+mkFrozenError fl ev = CFrozenErr { cc_id = ev, cc_flavor = fl }
+
+compatKind :: Kind -> Kind -> Bool
 compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 
 
-makeGivens :: CanonicalCts -> CanonicalCts
-makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol })
-          -- The UnkSkol doesn't matter because these givens are
-          -- not contradictory (else we'd have rejected them already)
-
-makeSolvedByInst :: CanonicalCt -> CanonicalCt
--- Record that a constraint is now solved
---       Wanted         -> Derived
---       Given, Derived -> no-op
-makeSolvedByInst ct 
-  | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc DerInst }
-  | otherwise                  = ct
-
-mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints
-mkWantedConstraints flats implics 
-  = mapBag (WcEvVar . deCanonicaliseWanted) flats `unionBags` mapBag WcImplic implics
-
-deCanonicaliseWanted :: CanonicalCt -> WantedEvVar
-deCanonicaliseWanted ct 
-  = WARN( not (isWanted $ cc_flavor ct), ppr ct ) 
-    let Wanted loc = cc_flavor ct 
-    in WantedEvVar (cc_id ct) loc
+deCanonicalise :: CanonicalCt -> FlavoredEvVar
+deCanonicalise ct = mkEvVarX (cc_id ct) (cc_flavor ct)
 
 tyVarsOfCanonical :: CanonicalCt -> TcTyVarSet
 tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
 tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
 tyVarsOfCanonical (CDictCan { cc_tyargs = tys })              = tyVarsOfTypes tys
-tyVarsOfCanonical (CIPCan { cc_ip_ty = ty })                  = tyVarsOfType ty
+tyVarsOfCanonical (CIPCan { cc_ip_ty = ty })                   = tyVarsOfType ty
+tyVarsOfCanonical (CFrozenErr { cc_id = ev })                  = tyVarsOfEvVar ev
 
 tyVarsOfCDict :: CanonicalCt -> TcTyVarSet 
 tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
@@ -228,31 +217,13 @@ instance Outputable CanonicalCt where
   ppr (CIPCan ip fl ip_nm ty)     
       = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
   ppr (CTyEqCan co fl tv ty)      
-      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
+      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty)
   ppr (CFunEqCan co fl tc tys ty) 
-      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
+      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyConApp tc tys) ty)
+  ppr (CFrozenErr co fl)
+      = ppr fl <+> pprEvVarWithType co
 \end{code}
 
-
-Note [No touchables as FunEq RHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Notice that (F xis ~ beta), where beta is an touchable unification
-variable, is not canonical.  Why?  
-  * If (F xis ~ beta) was the only wanted constraint, we'd 
-    definitely want to spontaneously-unify it
-
-  * But suppose we had an earlier wanted (beta ~ Int), and 
-    have already spontaneously unified it.  Then we have an
-    identity given (id : beta ~ Int) in the inert set.  
-
-  * But (F xis ~ beta) does not react with that given (because we
-    don't subsitute on the RHS of a function equality).  So there's a
-    serious danger that we'd spontaneously unify it a second time.
-
-Hence the invariant.
-
-The invariant is 
-
 Note [Canonical implicit parameter constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The type in a canonical implicit parameter constraint doesn't need to
@@ -300,8 +271,61 @@ isCFunEqCan_Maybe :: CanonicalCt -> Maybe TyCon
 isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc
 isCFunEqCan_Maybe _ = Nothing
 
+isCFrozenErr :: CanonicalCt -> Bool
+isCFrozenErr (CFrozenErr {}) = True
+isCFrozenErr _               = False
+
+
+-- A mixture of Given, Wanted, and Derived constraints. 
+-- We split between equalities and the rest to process equalities first. 
+data WorkList = WorkList { weqs  :: CanonicalCts 
+                                 -- NB: weqs includes equalities /and/ family equalities
+                         , wrest :: CanonicalCts }
+
+unionWorkList :: WorkList -> WorkList -> WorkList
+unionWorkList wl1 wl2
+  = WorkList { weqs = weqs wl1 `andCCan` weqs wl2
+             , wrest = wrest wl1 `andCCan` wrest wl2 }
+
+unionWorkLists :: [WorkList] -> WorkList 
+unionWorkLists = foldr unionWorkList emptyWorkList
+
+isEmptyWorkList :: WorkList -> Bool
+isEmptyWorkList wl = isEmptyCCan (weqs wl) && isEmptyCCan (wrest wl)
+
+emptyWorkList :: WorkList
+emptyWorkList
+  = WorkList { weqs = emptyBag, wrest = emptyBag }
+
+workListFromEq :: CanonicalCt -> WorkList
+workListFromEq = workListFromEqs . singleCCan
+
+workListFromNonEq :: CanonicalCt -> WorkList
+workListFromNonEq = workListFromNonEqs . singleCCan 
+
+workListFromNonEqs :: CanonicalCts -> WorkList
+workListFromNonEqs cts
+  = WorkList { weqs = emptyCCan, wrest = cts }
+
+workListFromEqs :: CanonicalCts -> WorkList
+workListFromEqs cts
+  = WorkList { weqs = cts, wrest = emptyCCan }
+
+foldrWorkListM :: (Monad m) => (CanonicalCt -> r -> m r) 
+                           -> r -> WorkList -> m r
+-- Prioritizes equalities
+foldrWorkListM on_ct r (WorkList {weqs = eqs, wrest = rest })
+  = do { r1 <- foldrBagM on_ct r eqs
+       ; foldrBagM on_ct r1 rest }
+
+instance Outputable WorkList where 
+  ppr wl = vcat [ text "WorkList (Equalities) = " <+> ppr (weqs wl)
+                , text "WorkList (Other)      = " <+> ppr (wrest wl) ]
+
 \end{code}
 
+
+
 %************************************************************************
 %*                                                                     *
                     CtFlavor
@@ -310,48 +334,24 @@ isCFunEqCan_Maybe _ = Nothing
 %************************************************************************
 
 \begin{code}
-data CtFlavor 
-  = Given   GivenLoc  -- We have evidence for this constraint in TcEvBinds
-  | Derived WantedLoc DerivedOrig
-                      -- We have evidence for this constraint in TcEvBinds;
-                      --   *however* this evidence can contain wanteds, so 
-                      --   it's valid only provisionally to the solution of
-                      --   these wanteds 
-  | Wanted WantedLoc  -- We have no evidence bindings for this constraint. 
-
-data DerivedOrig = DerSC | DerInst 
--- Deriveds are either superclasses of other wanteds or deriveds, or partially 
--- solved wanteds from instances. 
-
-instance Outputable CtFlavor where 
-  ppr (Given _)    = ptext (sLit "[Given]")
-  ppr (Wanted _)   = ptext (sLit "[Wanted]")
-  ppr (Derived {}) = ptext (sLit "[Derived]") 
-
-isWanted :: CtFlavor -> Bool 
-isWanted (Wanted {}) = True
-isWanted _           = False
-
-isGiven :: CtFlavor -> Bool 
-isGiven (Given {}) = True 
-isGiven _          = False 
-
-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 
-
-isWantedCt :: CanonicalCt -> Bool 
+getWantedLoc :: CanonicalCt -> WantedLoc
+getWantedLoc ct 
+  = ASSERT (isWanted (cc_flavor ct))
+    case cc_flavor ct of 
+      Wanted wl -> wl 
+      _         -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty
+
+isWantedCt :: CanonicalCt -> Bool
 isWantedCt ct = isWanted (cc_flavor ct)
-isGivenCt :: CanonicalCt -> Bool 
-isGivenCt ct = isGiven (cc_flavor ct) 
+isDerivedCt :: CanonicalCt -> Bool
+isDerivedCt ct = isDerived (cc_flavor ct)
+
+isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
+isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
+
+isGivenOrSolvedCt :: CanonicalCt -> Bool
+isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
+
 
 canSolve :: CtFlavor -> CtFlavor -> Bool 
 -- canSolve ctid1 ctid2 
@@ -361,12 +361,14 @@ canSolve :: CtFlavor -> CtFlavor -> Bool
 --  active(tv ~ xi)    = tv 
 --  active(D xis)      = D xis 
 --  active(IP nm ty)   = nm 
+--
+-- NB:  either (a `canSolve` b) or (b `canSolve` a) must hold
 -----------------------------------------
 canSolve (Given {})   _            = True 
-canSolve (Derived {}) (Wanted {})  = True 
-canSolve (Derived {}) (Derived {}) = True 
+canSolve (Wanted {})  (Derived {}) = True
 canSolve (Wanted {})  (Wanted {})  = True
-canSolve _ _ = False
+canSolve (Derived {}) (Derived {}) = True  -- Important: derived can't solve wanted/given
+canSolve _ _ = False                      -- (There is no *evidence* for a derived.)
 
 canRewrite :: CtFlavor -> CtFlavor -> Bool 
 -- canRewrite ctid1 ctid2 
@@ -375,19 +377,29 @@ canRewrite = canSolve
 
 combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
 -- Precondition: At least one of them should be wanted 
-combineCtLoc (Wanted loc) _    = loc 
-combineCtLoc _ (Wanted loc)    = loc 
-combineCtLoc (Derived loc _) _ = loc 
-combineCtLoc _ (Derived loc _) = loc 
+combineCtLoc (Wanted loc) _    = loc
+combineCtLoc _ (Wanted loc)    = loc
+combineCtLoc (Derived loc ) _  = loc
+combineCtLoc _ (Derived loc )  = loc
 combineCtLoc _ _ = panic "combineCtLoc: both given"
 
+mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
+mkSolvedFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk) GivenSolved
+mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
+
 mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
-mkGivenFlavor (Wanted  loc)   sk = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Derived loc _) sk = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Given   loc)   sk = Given (setCtLocOrigin loc sk)
+mkGivenFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
+
+mkWantedFlavor :: CtFlavor -> CtFlavor
+mkWantedFlavor (Wanted  loc) = Wanted loc
+mkWantedFlavor (Derived loc) = Wanted loc
+mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
 \end{code}
 
-
 %************************************************************************
 %*                                                                     *
 %*             The TcS solver monad                                    *
@@ -417,21 +429,54 @@ data TcSEnv
           -- Global type bindings
 
       tcs_context :: SimplContext,
+                     
+      tcs_untch :: TcsUntouchables,
+
+      tcs_ic_depth   :: Int,       -- Implication nesting depth
+      tcs_count      :: IORef Int, -- Global step count
 
-      tcs_untch :: Untouchables
+      tcs_flat_map   :: IORef FlatCache
     }
 
+data FlatCache 
+  = FlatCache { givenFlatCache  :: Map.Map FunEqHead (TcType,Coercion,CtFlavor)
+                -- Invariant: all CtFlavors here satisfy isGiven
+              , wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) }
+                -- Invariant: all CtFlavors here satisfy isWanted
+
+emptyFlatCache :: FlatCache
+emptyFlatCache 
+ = FlatCache { givenFlatCache  = Map.empty, wantedFlatCache = Map.empty }
+
+newtype FunEqHead = FunEqHead (TyCon,[Xi])
+
+instance Eq FunEqHead where
+  FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
+
+instance Ord FunEqHead where
+  FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2) 
+    = case compare tc1 tc2 of 
+        EQ    -> cmpTypes xis1 xis2
+        other -> other
+
+type TcsUntouchables = (Untouchables,TcTyVarSet)
+-- Like the TcM Untouchables, 
+-- but records extra TcsTv variables generated during simplification
+-- See Note [Extra TcsTv untouchables] in TcSimplify
+\end{code}
+
+\begin{code}
 data SimplContext
-  = SimplInfer         -- Inferring type of a let-bound thing
-  | SimplRuleLhs       -- Inferring type of a RULE lhs
-  | SimplInteractive   -- Inferring type at GHCi prompt
-  | SimplCheck         -- Checking a type signature or RULE rhs
+  = SimplInfer SDoc       -- Inferring type of a let-bound thing
+  | SimplRuleLhs RuleName  -- Inferring type of a RULE lhs
+  | SimplInteractive      -- Inferring type at GHCi prompt
+  | SimplCheck SDoc       -- Checking a type signature or RULE rhs
 
 instance Outputable SimplContext where
-  ppr SimplInfer       = ptext (sLit "SimplInfer")
-  ppr SimplRuleLhs     = ptext (sLit "SimplRuleLhs")
+  ppr (SimplInfer d)   = ptext (sLit "SimplInfer") <+> d
+  ppr (SimplCheck d)   = ptext (sLit "SimplCheck") <+> d
+  ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n)
   ppr SimplInteractive = ptext (sLit "SimplInteractive")
-  ppr SimplCheck       = ptext (sLit "SimplCheck")
 
 isInteractive :: SimplContext -> Bool
 isInteractive SimplInteractive = True
@@ -441,14 +486,14 @@ simplEqsOnly :: SimplContext -> Bool
 -- Simplify equalities only, not dictionaries
 -- This is used for the LHS of rules; ee
 -- Note [Simplifying RULE lhs constraints] in TcSimplify
-simplEqsOnly SimplRuleLhs = True
-simplEqsOnly _            = False
+simplEqsOnly (SimplRuleLhs {}) = True
+simplEqsOnly _                 = False
 
 performDefaulting :: SimplContext -> Bool
-performDefaulting SimplInfer              = False
-performDefaulting SimplRuleLhs            = False
-performDefaulting SimplInteractive = True
-performDefaulting SimplCheck       = True
+performDefaulting (SimplInfer {})   = False
+performDefaulting (SimplRuleLhs {}) = False
+performDefaulting SimplInteractive  = True
+performDefaulting (SimplCheck {})   = True
 
 ---------------
 newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 
@@ -486,8 +531,21 @@ panicTcS doc = pprPanic "TcCanonical" doc
 traceTcS :: String -> SDoc -> TcS ()
 traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc
 
-traceTcS0 :: String -> SDoc -> TcS ()
-traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
+bumpStepCountTcS :: TcS ()
+bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
+                                    ; n <- TcM.readTcRef ref
+                                    ; TcM.writeTcRef ref (n+1) }
+
+traceFireTcS :: Int -> SDoc -> TcS ()
+-- Dump a rule-firing trace
+traceFireTcS depth doc 
+  = TcS $ \env -> 
+    TcM.ifDOptM Opt_D_dump_cs_trace $ 
+    do { n <- TcM.readTcRef (tcs_count env)
+       ; let msg = int n 
+                <> text (replicate (tcs_ic_depth env) '>')
+                <> brackets (int depth) <+> doc
+       ; TcM.dumpTcRn msg }
 
 runTcS :: SimplContext
        -> Untouchables                -- Untouchables
@@ -496,35 +554,66 @@ runTcS :: SimplContext
 runTcS context untouch tcs 
   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
        ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
+       ; step_count <- TcM.newTcRef 0
+       ; flat_cache_var <- TcM.newTcRef emptyFlatCache
        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
                           , tcs_ty_binds = ty_binds_var
-                          , tcs_context = context
-                          , tcs_untch   = untouch }
+                          , tcs_context  = context
+                          , tcs_untch    = (untouch, emptyVarSet) -- No Tcs untouchables yet
+                         , tcs_count    = step_count
+                         , tcs_ic_depth = 0
+                          , tcs_flat_map = flat_cache_var
+                          }
 
             -- Run the computation
        ; res <- unTcS tcs env
-
             -- Perform the type unifications required
        ; ty_binds <- TcM.readTcRef ty_binds_var
        ; mapM_ do_unification (varEnvElts ty_binds)
 
+#ifdef DEBUG
+       ; count <- TcM.readTcRef step_count
+       ; when (opt_PprStyle_Debug && count > 0) $
+         TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") 
+                            <+> int count <+> ppr context)
+#endif
              -- And return
-       ; ev_binds <- TcM.readTcRef evb_ref
+       ; ev_binds      <- TcM.readTcRef evb_ref
        ; return (res, evBindMapBinds ev_binds) }
   where
     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
 
-       
-nestImplicTcS :: EvBindsVar -> Untouchables -> TcS a -> TcS a 
-nestImplicTcS ref untch (TcS thing_inside)
-  = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } -> 
-    let 
-       nest_env = TcSEnv { tcs_ev_binds = ref
-                         , tcs_ty_binds = ty_binds
-                         , tcs_untch    = untch
-                         , tcs_context  = ctxtUnderImplic ctxt }
-    in 
-    thing_inside nest_env
+nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a
+nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
+  = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds 
+                  , tcs_untch = (_outer_range, outer_tcs)
+                  , tcs_count = count
+                  , tcs_ic_depth = idepth
+                   , tcs_context = ctxt 
+                   , tcs_flat_map = orig_flat_cache_var
+                   } ->
+    do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
+                          -- The inner_range should be narrower than the outer one
+                  -- (thus increasing the set of untouchables) but 
+                  -- the inner Tcs-untouchables must be unioned with the
+                  -- outer ones!
+
+       ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
+       ; flat_cache_var  <- TcM.newTcRef orig_flat_cache
+       -- One could be more conservative as well: 
+       -- ; flat_cache_var  <- TcM.newTcRef emptyFlatCache 
+
+                            -- Consider copying the results the tcs_flat_map of the 
+                            -- incomping constraint, but we must make sure that we
+                            -- have pushed everything in, which seems somewhat fragile
+       ; let nest_env = TcSEnv { tcs_ev_binds = ref
+                               , tcs_ty_binds = ty_binds
+                               , tcs_untch    = inner_untch
+                               , tcs_count    = count
+                               , tcs_ic_depth = idepth+1
+                               , tcs_context  = ctxtUnderImplic ctxt 
+                               , tcs_flat_map = flat_cache_var }
+       ; thing_inside nest_env }
 
 recoverTcS :: TcS a -> TcS a -> TcS a
 recoverTcS (TcS recovery_code) (TcS thing_inside)
@@ -533,18 +622,21 @@ recoverTcS (TcS recovery_code) (TcS thing_inside)
 
 ctxtUnderImplic :: SimplContext -> SimplContext
 -- See Note [Simplifying RULE lhs constraints] in TcSimplify
-ctxtUnderImplic SimplRuleLhs = SimplCheck
-ctxtUnderImplic ctxt         = ctxt
+ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") 
+                                               <+> doubleQuotes (ftext n))
+ctxtUnderImplic ctxt              = ctxt
 
-tryTcS :: TcS a -> TcS a 
--- Like runTcS, but from within the TcS monad 
+tryTcS :: TcS a -> TcS a
+-- Like runTcS, but from within the TcS monad
 -- Ignore all the evidence generated, and do not affect caller's evidence!
-tryTcS tcs 
+tryTcS tcs
   = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
                     ; ev_binds_var <- TcM.newTcEvBinds
+                    ; flat_cache_var <- TcM.newTcRef emptyFlatCache
                     ; let env1 = env { tcs_ev_binds = ev_binds_var
-                                     , tcs_ty_binds = ty_binds_var }
-                    ; unTcS tcs env1 })
+                                     , tcs_ty_binds = ty_binds_var
+                                     , tcs_flat_map = flat_cache_var }
+                   ; unTcS tcs env1 })
 
 -- Update TcEvBinds 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -558,36 +650,76 @@ getTcSContext = TcS (return . tcs_context)
 getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds) 
 
-getUntouchables :: TcS Untouchables 
+getUntouchables :: TcS TcsUntouchables
 getUntouchables = TcS (return . tcs_untch)
 
 getTcSTyBinds :: TcS (IORef (TyVarEnv (TcTyVar, TcType)))
 getTcSTyBinds = TcS (return . tcs_ty_binds)
 
-getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) 
+getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
 getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
 
+getFlatCacheMapVar :: TcS (IORef FlatCache)
+getFlatCacheMapVar
+  = TcS (return . tcs_flat_map)
+
+lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor 
+                   -> TcS (Maybe (TcType,Coercion,CtFlavor))
+-- For givens, we lookup in given flat cache
+lookupFlatCacheMap tc xis (Given {})
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) }
+-- For wanteds, we first lookup in givenFlatCache.
+-- If we get nothing back then we lookup in wantedFlatCache.
+lookupFlatCacheMap tc xis (Wanted {})
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of
+           Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map)
+           other   -> return other }
+lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing
+
+updateFlatCacheMap :: TyCon -> [Xi]
+                   -> TcType -> CtFlavor -> Coercion -> TcS ()
+updateFlatCacheMap _tc _xis _tv (Derived {}) _co
+  = return () -- Not caching deriveds
+updateFlatCacheMap tc xis ty fl co
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; let new_cache_map
+              | isGivenOrSolved fl
+              = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+                                             givenFlatCache cache_map }
+              | isWanted fl
+              = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+                                              wantedFlatCache cache_map }
+              | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty
+       ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map }
+
 
 getTcEvBindsBag :: TcS EvBindMap
 getTcEvBindsBag
   = do { EvBindsVar ev_ref _ <- getTcEvBinds 
        ; wrapTcS $ TcM.readTcRef ev_ref }
 
-setWantedCoBind :: CoVar -> Coercion -> TcS () 
-setWantedCoBind cv co 
-  = setEvBind cv (EvCoercion co)
-     -- Was: wrapTcS $ TcM.writeWantedCoVar cv co 
 
-setDerivedCoBind :: CoVar -> Coercion -> TcS () 
-setDerivedCoBind cv co 
-  = setEvBind cv (EvCoercion co)
+setCoBind :: CoVar -> Coercion -> TcS () 
+setCoBind cv co = setEvBind cv (EvCoercion co)
 
 setWantedTyBind :: TcTyVar -> TcType -> TcS () 
 -- Add a type binding
+-- We never do this twice!
 setWantedTyBind tv ty 
   = do { ref <- getTcSTyBinds
        ; wrapTcS $ 
          do { ty_binds <- TcM.readTcRef ref
+#ifdef DEBUG
+            ; TcM.checkErr (not (tv `elemVarEnv` ty_binds)) $
+              vcat [ text "TERRIBLE ERROR: double set of meta type variable"
+                   , ppr tv <+> text ":=" <+> ppr ty
+                   , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
+#endif
             ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
 
 setIPBind :: EvVar -> EvTerm -> TcS () 
@@ -599,12 +731,9 @@ setDictBind = setEvBind
 setEvBind :: EvVar -> EvTerm -> TcS () 
 -- Internal
 setEvBind ev rhs 
-  = do { tc_evbinds <- getTcEvBinds 
+  = do { tc_evbinds <- getTcEvBinds
        ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) }
 
-newTcEvBindsTcS :: TcS EvBindsVar
-newTcEvBindsTcS = wrapTcS (TcM.newTcEvBinds)
-
 warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
 warnTcS loc warn_if doc 
   | warn_if   = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
@@ -631,6 +760,12 @@ getTopEnv = wrapTcS $ TcM.getTopEnv
 getGblEnv :: TcS TcGblEnv 
 getGblEnv = wrapTcS $ TcM.getGblEnv 
 
+tcsLookupClass :: Name -> TcS Class
+tcsLookupClass name = wrapTcS (TcM.tcLookupClass name)
+
+tcsLookupTyCon :: Name -> TcS TyCon
+tcsLookupTyCon name = wrapTcS (TcM.tcLookupTyCon name)
+
 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -644,17 +779,18 @@ checkWellStagedDFun pred dfun_id loc
     bind_lvl = TcM.topIdLvl dfun_id
 
 pprEq :: TcType -> TcType -> SDoc
-pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
+pprEq ty1 ty2 = pprPredTy $ mkEqPred (ty1,ty2)
 
 isTouchableMetaTyVar :: TcTyVar -> TcS Bool
 isTouchableMetaTyVar tv 
   = do { untch <- getUntouchables
        ; return $ isTouchableMetaTyVar_InRange untch tv } 
 
-isTouchableMetaTyVar_InRange :: Untouchables -> TcTyVar -> Bool 
-isTouchableMetaTyVar_InRange untch tv 
+isTouchableMetaTyVar_InRange :: TcsUntouchables -> TcTyVar -> Bool 
+isTouchableMetaTyVar_InRange (untch,untch_tcs) tv 
   = case tcTyVarDetails tv of 
-      MetaTv TcsTv _ -> True    -- See Note [Touchable meta type variables] 
+      MetaTv TcsTv _ -> not (tv `elemVarSet` untch_tcs)
+                        -- See Note [Touchable meta type variables] 
       MetaTv {}      -> inTouchableRange untch tv 
       _              -> False 
 
@@ -683,9 +819,12 @@ newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
 
 newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
 newFlattenSkolemTyVar ty
-  = wrapTcS $ do { uniq <- TcM.newUnique
-                 ; let name = mkSysTvName uniq (fsLit "f")
-                 ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) }
+  = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique
+                            ; let name = TcM.mkTcTyVarName uniq (fsLit "f")
+                            ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } 
+       ; traceTcS "New Flatten Skolem Born" $ 
+           (ppr tv <+> text "[:= " <+> ppr ty <+> text "]")
+       ; return tv }
 
 -- Instantiations 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -695,35 +834,43 @@ instDFunTypes mb_inst_tys
   = mapM inst_tv mb_inst_tys
   where
     inst_tv :: Either TyVar TcType -> TcS Type
-    inst_tv (Left tv)  = mkTyVarTy <$> newFlexiTcS tv
+    inst_tv (Left tv)  = mkTyVarTy <$> instFlexiTcS tv
     inst_tv (Right ty) = return ty 
 
 instDFunConstraints :: TcThetaType -> TcS [EvVar] 
 instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds 
 
 
--- newFlexiTcS :: TyVar -> TcS TcTyVar
--- -- Make a TcsTv meta tyvar; it is always touchable,
--- -- but we are supposed to guess its instantiation
--- -- See Note [Touchable meta type variables]
--- newFlexiTcS tv = wrapTcS $ TcM.instMetaTyVar TcsTv tv
-
-newFlexiTcS :: TyVar -> TcS TcTyVar 
+instFlexiTcS :: TyVar -> TcS TcTyVar 
 -- Like TcM.instMetaTyVar but the variable that is created is always
 -- touchable; we are supposed to guess its instantiation. 
 -- See Note [Touchable meta type variables] 
-newFlexiTcS tv = newFlexiTcSHelper (tyVarName tv) (tyVarKind tv) 
+instFlexiTcS tv = instFlexiTcSHelper (tyVarName tv) (tyVarKind tv) 
 
-newKindConstraint :: TcTyVar -> Kind -> TcS (CoVar, Type)  
+newFlexiTcSTy :: Kind -> TcS TcType  
+newFlexiTcSTy knd 
+  = wrapTcS $
+    do { uniq <- TcM.newUnique 
+       ; ref  <- TcM.newMutVar  Flexi 
+       ; let name = TcM.mkTcTyVarName uniq (fsLit "uf")
+       ; return $ mkTyVarTy (mkTcTyVar name knd (MetaTv TcsTv ref)) }
+
+isFlexiTcsTv :: TyVar -> Bool
+isFlexiTcsTv tv
+  | not (isTcTyVar tv)                  = False
+  | MetaTv TcsTv _ <- tcTyVarDetails tv = True
+  | otherwise                           = False
+
+newKindConstraint :: TcTyVar -> Kind -> TcS CoVar
 -- Create new wanted CoVar that constrains the type to have the specified kind. 
 newKindConstraint tv knd 
-  = do { tv_k <- newFlexiTcSHelper (tyVarName tv) knd 
+  = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd 
        ; let ty_k = mkTyVarTy tv_k
-       ; co_var <- newWantedCoVar (mkTyVarTy tv) ty_k
-       ; return (co_var, ty_k) }
+       ; co_var <- newCoVar (mkTyVarTy tv) ty_k
+       ; return co_var }
 
-newFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar
-newFlexiTcSHelper tvname tvkind
+instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar
+instFlexiTcSHelper tvname tvkind
   = wrapTcS $ 
     do { uniq <- TcM.newUnique 
        ; ref  <- TcM.newMutVar  Flexi 
@@ -734,27 +881,23 @@ newFlexiTcSHelper tvname tvkind
 -- Superclasses and recursive dictionaries 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-newGivOrDerEvVar :: TcPredType -> EvTerm -> TcS EvVar 
-newGivOrDerEvVar pty evtrm 
-  = do { ev <- wrapTcS $ TcM.newEvVar pty 
-       ; setEvBind ev evtrm 
-       ; return ev }
+newEvVar :: TcPredType -> TcS EvVar
+newEvVar pty = wrapTcS $ TcM.newEvVar pty
+
+newDerivedId :: TcPredType -> TcS EvVar 
+newDerivedId pty = wrapTcS $ TcM.newEvVar pty
 
-newGivOrDerCoVar :: TcType -> TcType -> Coercion -> TcS EvVar 
+newGivenCoVar :: TcType -> TcType -> Coercion -> TcS EvVar 
 -- Note we create immutable variables for given or derived, since we
 -- must bind them to TcEvBinds (because their evidence may involve 
 -- superclasses). However we should be able to override existing
 -- 'derived' evidence, even in TcEvBinds 
-newGivOrDerCoVar ty1 ty2 co 
+newGivenCoVar ty1 ty2 co 
   = do { cv <- newCoVar ty1 ty2
        ; setEvBind cv (EvCoercion co) 
        ; return cv } 
 
-newWantedCoVar :: TcType -> TcType -> TcS EvVar 
-newWantedCoVar ty1 ty2 =  wrapTcS $ TcM.newWantedCoVar ty1 ty2 
-
-
-newCoVar :: TcType -> TcType -> TcS EvVar 
+newCoVar :: TcType -> TcType -> TcS EvVar
 newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2 
 
 newIPVar :: IPName Name -> TcType -> TcS EvVar 
@@ -766,83 +909,6 @@ newDictVar cl tys = wrapTcS $ TcM.newDict cl tys
 
 
 \begin{code} 
-isGoodRecEv :: EvVar -> WantedEvVar -> 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
--- or                   wv = EvCast x |> ev
--- etc. 
--- But that would be Very Bad if the evidence for 'ev' mentions 'wv',
--- in an "unguarded" way. So isGoodRecEv looks at the evidence ev 
--- recursively through the evidence binds, to see if uses of 'wv' are guarded.
---
--- Guarded means: more instance calls than superclass selections. We
--- compute this by chasing the evidence, adding +1 for every instance
--- call (constructor) and -1 for every superclass selection (destructor).
---
--- See Note [Superclasses and recursive dictionaries] in TcInteract
-isGoodRecEv ev_var (WantedEvVar wv _)
-  = do { tc_evbinds <- getTcEvBindsBag 
-       ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var 
-       ; return $ case mb of 
-                    Nothing -> True 
-                    Just min_guardedness -> min_guardedness > 0
-       }
-
-  where chase_ev_var :: EvBindMap   -- Evidence binds 
-                 -> EvVar           -- Target variable whose gravity we want to return
-                 -> Int             -- Current gravity 
-                 -> [EvVar]         -- Visited nodes
-                 -> EvVar           -- Current node 
-                 -> TcS (Maybe Int)
-        chase_ev_var assocs trg curr_grav visited orig
-            | trg == orig         = return $ Just curr_grav
-            | orig `elem` visited = return $ Nothing 
-            | 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 
-
-        chase_ev assocs trg curr_grav visited (EvId v) 
-            = chase_ev_var assocs trg curr_grav visited v
-        chase_ev assocs trg curr_grav visited (EvSuperClass d_id _) 
-            = chase_ev_var assocs trg (curr_grav-1) visited d_id
-        chase_ev assocs trg curr_grav visited (EvCast v co)
-            = do { m1 <- chase_ev_var assocs trg curr_grav visited v
-                 ; m2 <- chase_co assocs trg curr_grav visited co
-                 ; return (comb_chase_res Nothing [m1,m2]) } 
-
-        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_co assocs trg curr_grav visited co 
-            = -- Look for all the coercion variables in the coercion 
-              -- chase them, and combine the results. This is OK since the
-              -- coercion will not contain any superclass terms -- anything 
-              -- that involves dictionaries will be bound in assocs. 
-              let co_vars       = foldVarSet (\v vrs -> if isCoVar v then (v:vrs) else vrs) []
-                                             (tyVarsOfType co)
-              in do { chase_results <- mapM (chase_ev_var assocs trg curr_grav visited) co_vars
-                    ; return (comb_chase_res Nothing chase_results) } 
-
-        comb_chase_res f []                   = f 
-        comb_chase_res f (Nothing:rest)       = comb_chase_res f rest 
-        comb_chase_res Nothing (Just n:rest)  = comb_chase_res (Just n) rest
-        comb_chase_res (Just m) (Just n:rest) = comb_chase_res (Just (min n m)) rest 
-
-
 -- Matching and looking up classes and family instances
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -857,24 +923,23 @@ matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcT
 matchClass clas tys
   = do { let pred = mkClassPred clas tys 
         ; instEnvs <- getInstEnvs
-       ; case lookupInstEnv instEnvs clas tys of {
-            ([], unifs)               -- Nothing matches  
+        ; case lookupInstEnv instEnvs clas tys of {
+            ([], 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, 
                                          text "witness" <+> ppr dfun_id
-                                          <+> ppr (idType 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 
+           (matches, unifs, _)          -- More than one matches 
                -> do   { traceTcS "matchClass multiple matches, deferring choice"
                                   (vcat [text "dict" <+> ppr pred,
                                          text "matches" <+> ppr matches,
@@ -883,26 +948,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
@@ -913,46 +960,4 @@ matchFam tycon args
        -- DV: We never return MatchInstMany, since tcLookupFamInst never returns 
        -- multiple matches. Check. 
        }
-
-
-zonkTcTypeTcS :: TcType -> TcS TcType
--- Zonk through the TyBinds of the Tcs Monad
-zonkTcTypeTcS ty 
-  = do { subst <- getTcSTyBindsMap >>= return . varEnvElts 
-       ; let (dom,rng)  = unzip subst 
-             apply_once = substTyWith dom rng 
-       ; let rng_idemp = [ substTyWith dom rng_idemp (apply_once t) | t <- rng ]
-       ; return (substTyWith dom rng_idemp ty) }
-
-                        
-
-
-
-
--- Functional dependencies, instantiation of equations
--------------------------------------------------------
-
-mkWantedFunDepEqns :: WantedLoc -> [(Equation, (PredType, SDoc), (PredType, SDoc))]
-                   -> TcS [WantedEvVar] 
-mkWantedFunDepEqns _   [] = return []
-mkWantedFunDepEqns loc eqns
-  = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns))
-       ; wevvars <- mapM to_work_item eqns
-       ; return $ concat wevvars }
-  where
-    to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar]
-    to_work_item ((qtvs, pairs), _, _)
-      = do { let tvs = varSetElems qtvs
-           ; tvs' <- mapM newFlexiTcS tvs
-           ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
-           ; mapM (do_one subst) pairs }
-
-    do_one subst (ty1, ty2) = do { let sty1 = substTy subst ty1 
-                                       sty2 = substTy subst ty2 
-                                ; ev <- newWantedCoVar sty1 sty2
-                                ; return (WantedEvVar ev loc) }
-
-pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
-pprEquationDoc (eqn, (p1, _), (p2, _)) 
-  = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
 \end{code}