GHC gets a new constraint solver. More efficient and smaller in size.

35 files changed, 3230 insertions, 2426 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index 2e9125ba43..c2cf0bfcdd 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -858,16 +858,17 @@ dataConCannotMatch tys con
   | all isTyVarTy tys = False	-- Also common
   | otherwise
   = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
-                   | (ty1, ty2) <- concatMap (predEqs . predTypePredTree) theta ]
+                   | (ty1, ty2) <- concatMap predEqs theta ]
   where
     dc_tvs  = dataConUnivTyVars con
     theta   = dataConTheta con
     subst   = zipTopTvSubst dc_tvs tys
 
     -- TODO: could gather equalities from superclasses too
-    predEqs (EqPred ty1 ty2) = [(ty1, ty2)]
-    predEqs (TuplePred ts)   = concatMap predEqs ts
-    predEqs _                = []
+    predEqs pred = case classifyPredType pred of
+                     EqPred ty1 ty2 -> [(ty1, ty2)]
+                     TuplePred ts   -> concatMap predEqs ts
+                     _              -> []
 \end{code}
 
 %************************************************************************
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index c5f56d8712..a40d46f8a9 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -48,7 +48,7 @@ import Type
 import Coercion
 import TcType
 import MkCore
-import CoreUtils	( exprType, mkCoerce )
+import CoreUtils	( exprType, mkCast )
 import CoreUnfold
 import Literal
 import TyCon
@@ -683,7 +683,7 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapNewTypeBody tycon args result_expr
   = ASSERT( isNewTyCon tycon )
     wrapFamInstBody tycon args $
-    mkCoerce (mkSymCo co) result_expr
+    mkCast result_expr (mkSymCo co)
   where
     co = mkAxInstCo (newTyConCo tycon) args
 
@@ -695,7 +695,7 @@ wrapNewTypeBody tycon args result_expr
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
   = ASSERT( isNewTyCon tycon )
-    mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr
+    mkCast result_expr (mkAxInstCo (newTyConCo tycon) args)
 
 -- If the type constructor is a representation type of a data instance, wrap
 -- the expression into a cast adjusting the expression type, which is an
@@ -705,14 +705,14 @@ unwrapNewTypeBody tycon args result_expr
 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapFamInstBody tycon args body
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body
+  = mkCast body (mkSymCo (mkAxInstCo co_con args))
   | otherwise
   = body
 
 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapFamInstScrut tycon args scrut
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkAxInstCo co_con args) scrut
+  = mkCast scrut (mkAxInstCo co_con args)
   | otherwise
   = scrut
 \end{code}
diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index c3141f4fd7..e4fe386043 100644
--- a/compiler/codeGen/CgCase.lhs
+++ b/compiler/codeGen/CgCase.lhs
@@ -47,6 +47,7 @@ import Type
 import TyCon
 import Util
 import Outputable
+import FastString
 
 import Control.Monad (when)
 \end{code}
@@ -127,6 +128,13 @@ allocating more heap than strictly necessary, but it will sometimes
 eliminate a heap check altogether.
 
 \begin{code}
+cgCase (StgApp _v []) _live_in_whole_case _live_in_alts bndr
+       (PrimAlt _) [(DEFAULT,bndrs,_,rhs)]
+  | isVoidArg (idCgRep bndr)
+  = ASSERT( null bndrs )
+    WARN( True, ptext (sLit "Case of void constant; missing optimisation somewhere") <+> ppr bndr)
+    cgExpr rhs
+
 cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
        alt_type@(PrimAlt _) alts
   -- Note [ticket #3132]: we might be looking at a case of a lifted Id
@@ -147,17 +155,18 @@ cgCase (StgApp v []) _live_in_whole_case _live_in_alts bndr
   -- the HValue really is a MutVar#.  The types are compatible though,
   -- so we can just generate an assignment.
   || reps_compatible
-  =
-     do	{ -- Careful! we can't just bind the default binder to the same thing
+  =  do { when (not reps_compatible) $
+            panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+
+          -- Careful! we can't just bind the default binder to the same thing
 	  -- as the scrutinee, since it might be a stack location, and having
 	  -- two bindings pointing at the same stack locn doesn't work (it
 	  -- confuses nukeDeadBindings).  Hence, use a new temp.
-          when (not reps_compatible) $
-            panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
 	; v_info <- getCgIdInfo v
 	; amode <- idInfoToAmode v_info
 	; tmp_reg <- bindNewToTemp bndr
 	; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
+
 	; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
   where
     reps_compatible = idCgRep v == idCgRep bndr
@@ -327,6 +336,7 @@ cgInlinePrimOp primop args bndr (PrimAlt _) live_in_alts alts
   = ASSERT( con == DEFAULT && isSingleton alts && null bs )
     do	{ 	-- VOID RESULT; just sequencing, 
 		-- so get in there and do it
+		-- The bndr should not occur, so no need to bind it
 	  cgPrimOp [] primop args live_in_alts
 	; cgExpr rhs }
   where
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index abefa45713..77747aabf3 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -297,6 +297,21 @@ lintCoreExpr (Let (Rec pairs) body)
     (_, dups) = removeDups compare bndrs
 
 lintCoreExpr e@(App _ _)
+{- DV: This grievous hack (from ghc-constraint-solver should not be needed: 
+    | Var x <- fun -- Greivous hack for Eq# construction: Eq# may have type arguments
+                   -- of kind (* -> *) but its type insists on *. When we have polymorphic kinds,
+                   -- we should do this properly
+    , Just dc <- isDataConWorkId_maybe x
+    , dc == eqBoxDataCon
+    , [Type arg_ty1, Type arg_ty2, co_e] <- args
+    = do arg_ty1' <- lintInTy arg_ty1
+         arg_ty2' <- lintInTy arg_ty2
+         unless (typeKind arg_ty1' `eqKind` typeKind arg_ty2')
+                (addErrL (mkEqBoxKindErrMsg arg_ty1 arg_ty2))
+         
+         lintCoreArg (mkCoercionType arg_ty1' arg_ty2' `mkFunTy` mkEqPred (arg_ty1', arg_ty2')) co_e
+    | otherwise
+-}
     = do { fun_ty <- lintCoreExpr fun
          ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
   where
@@ -460,13 +475,10 @@ checkTyKind tyvar arg_ty
 checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType)
 checkTyCoKind tv co
   = do { (t1,t2) <- lintCoercion co
-       ; k1      <- lintType t1
-       ; k2      <- lintType t2
-       ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind))
+            -- t1,t2 have the same kind
+       ; unless (typeKind t1 `isSubKind` tyVarKind tv)
                 (addErrL (mkTyCoAppErrMsg tv co))
        ; return (t1,t2) }
-  where 
-    tyvar_kind = tyVarKind tv
 
 checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
 checkTyCoKinds = zipWithM checkTyCoKind
@@ -688,6 +700,29 @@ lintTyBndrKind tv =
   else lintKind ki  -- type forall
 
 -------------------
+{-
+lint_prim_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType)
+lint_prim_eq_co tc co arg_cos = case arg_cos of 
+  [co1,co2] -> do { (t1,s1) <- lintCoercion co1
+                  ; (t2,s2) <- lintCoercion co2
+                  ; checkL (typeKind t1 `eqKind` typeKind t2) $ 
+                    ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
+                  ; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
+  _ -> failWithL (ptext (sLit "Unsaturated or oversaturated ~# coercion") <+> ppr co)
+
+lint_eq_co :: TyCon -> OutCoercion -> [OutCoercion] -> LintM (OutType,OutType) 
+lint_eq_co tc co arg_cos = case arg_cos of 
+  [co1,co2] -> do { (t1,s1) <- lintCoercion co1
+                  ; (t2,s2) <- lintCoercion co2
+                  ; checkL (typeKind t1 `eqKind` typeKind t2) $
+                    ptext (sLit "Mismatched arg kinds in coercion application:") <+> ppr co
+                  ; return (mkTyConApp tc [t1,t2], mkTyConApp tc [s1,s2]) }
+  [co1] -> do { (t1,s1) <- lintCoercion co1
+              ; return (mkTyConApp tc [t1], mkTyConApp tc [s1]) }
+  [] -> return (mkTyConApp tc [], mkTyConApp tc [])
+  _ -> failWithL (ptext (sLit "Oversaturated ~ coercion") <+> ppr co) 
+-}
+
 lintKindCoercion :: OutCoercion -> LintM OutKind
 -- Kind coercions are only reflexivity because they mean kind
 -- instantiation.  See Note [Kind coercions] in Coercion
@@ -700,11 +735,28 @@ lintKindCoercion co
 
 lintCoercion :: OutCoercion -> LintM (OutType, OutType)
 -- Check the kind of a coercion term, returning the kind
+-- Post-condition: the returned OutTypes are lint-free
+--                 and have the same kind as each other
 lintCoercion (Refl ty)
-  = do { _k <- lintType ty
+  = do { _ <- lintType ty
        ; return (ty, ty) }
 
 lintCoercion co@(TyConAppCo tc cos)
+{- DV: This grievous hack (from ghc-constraint-solver) should not be needed any more:
+  | tc `hasKey` eqPrimTyConKey      -- Just as in lintType, treat applications of (~) and (~#)
+  = lint_prim_eq_co tc co cos       -- specially to allow for polymorphism. This hack will 
+                                    -- hopefully go away when we merge in kind polymorphism.
+  | tc `hasKey` eqTyConKey
+  = lint_eq_co tc co cos
+
+  | otherwise
+  = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
+       ; let kind_to_check = if (tc `hasKey` funTyConKey) && (length cos == 2)
+                             then mkArrowKinds [argTypeKind,openTypeKind] liftedTypeKind
+                             else tyConKind tc -- TODO: Fix this when kind polymorphism is in! 
+       ; check_co_app co kind_to_check ss
+       ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
+-}
   = do   -- We use the kind of the type constructor to know how many
          -- kind coercions we have (one kind coercion for one kind
          -- instantiation).
@@ -721,6 +773,7 @@ lintCoercion co@(TyConAppCo tc cos)
        ; check_co_app co ki (kis ++ ss)
        ; return (mkTyConApp tc (kis ++ ss), mkTyConApp tc (kis ++ ts)) }
 
+
 lintCoercion co@(AppCo co1 co2)
   = do { (s1,t1) <- lintCoercion co1
        ; (s2,t2) <- lintCoercion co2
@@ -740,7 +793,8 @@ lintCoercion (CoVarCo cv)
                   2 (ptext (sLit "With offending type:") <+> ppr (varType cv)))
   | otherwise
   = do { checkTyCoVarInScope cv
-       ; return (coVarKind cv) }
+       ; cv' <- lookupIdInScope cv 
+       ; return (coVarKind cv') }
 
 lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
                                    , co_ax_lhs = lhs
@@ -759,8 +813,8 @@ lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = ktvs
     (kcos, tcos) = splitAt (length kvs) cos
 
 lintCoercion (UnsafeCo ty1 ty2)
-  = do { _k1 <- lintType ty1
-       ; _k2 <- lintType ty2
+  = do { _ <- lintType ty1
+       ; _ <- lintType ty2
        ; return (ty1, ty2) }
 
 lintCoercion (SymCo co) 
@@ -794,7 +848,7 @@ lintCoercion (InstCo co arg_ty)
 	  Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
 
 ----------
-checkTcApp :: Coercion -> Int -> Type -> LintM Type
+checkTcApp :: OutCoercion -> Int -> Type -> LintM OutType
 checkTcApp co n ty
   | Just tys <- tyConAppArgs_maybe ty
   , n < length tys
@@ -988,10 +1042,10 @@ updateTvSubst subst' m =
 getTvSubst :: LintM TvSubst
 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
 
-applySubstTy :: Type -> LintM Type
+applySubstTy :: InType -> LintM OutType
 applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }
 
-applySubstCo :: Coercion -> LintM Coercion
+applySubstCo :: InCoercion -> LintM OutCoercion
 applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
 
 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 728c4ec446..741c48eac9 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -949,7 +949,8 @@ simple_opt_expr' subst expr
       = case altcon of
           DEFAULT -> go rhs
           _       -> mkLets (catMaybes mb_binds) $ simple_opt_expr subst' rhs
-            where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst (zipEqual "simpleOptExpr" bs es)
+            where (subst', mb_binds) = mapAccumL simple_opt_out_bind subst 
+                                                 (zipEqual "simpleOptExpr" bs es)
 
       | otherwise
       = Case e' b' (substTy subst ty)
@@ -1016,9 +1017,11 @@ simple_opt_bind' subst (NonRec b r)
 
 ----------------------
 simple_opt_out_bind :: Subst -> (InVar, OutExpr) -> (Subst, Maybe CoreBind)
-simple_opt_out_bind subst (b, r') = case maybe_substitute subst b r' of
-      Just ext_subst -> (ext_subst, Nothing)
-      Nothing        -> (subst', Just (NonRec b2 r'))
+simple_opt_out_bind subst (b, r') 
+  | Just ext_subst <- maybe_substitute subst b r'
+  = (ext_subst, Nothing)
+  | otherwise
+  = (subst', Just (NonRec b2 r'))
   where
     (subst', b') = subst_opt_bndr subst b
     b2 = add_info subst' b b'
@@ -1038,6 +1041,8 @@ maybe_substitute subst b r
     Just (extendCvSubst subst b co)
 
   | isId b              -- let x = e in <body>
+  , not (isCoVar b)	-- See Note [Do not inline CoVars unconditionally]
+    		 	-- in SimplUtils
   , safe_to_inline (idOccInfo b) 
   , isAlwaysActive (idInlineActivation b)	-- Note [Inline prag in simplOpt]
   , not (isStableUnfolding (idUnfolding b))
@@ -1257,7 +1262,7 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args)
 
           -- Cast the value arguments (which include dictionaries)
         new_val_args = zipWith cast_arg arg_tys val_args
-        cast_arg arg_ty arg = mkCoerce (theta_subst arg_ty) arg
+        cast_arg arg_ty arg = mkCast arg (theta_subst arg_ty)
 
         dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
                          ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index c06589860e..27026b2353 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -9,7 +9,8 @@ Utility functions on @Core@ syntax
 -- | Commonly useful utilites for manipulating the Core language
 module CoreUtils (
         -- * Constructing expressions
-        mkTick, mkTickNoHNF, mkCoerce,
+        mkCast,
+        mkTick, mkTickNoHNF,
         bindNonRec, needsCaseBinding,
         mkAltExpr, mkPiType, mkPiTypes,
 
@@ -190,15 +191,27 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
 \begin{code}
 -- | Wrap the given expression in the coercion safely, dropping
 -- identity coercions and coalescing nested coercions
-mkCoerce :: Coercion -> CoreExpr -> CoreExpr
-mkCoerce co e | isReflCo co = e
-mkCoerce co (Cast expr co2)
+mkCast :: CoreExpr -> Coercion -> CoreExpr
+mkCast e co | isReflCo co = e
+
+mkCast (Coercion e_co) co 
+  = Coercion new_co
+  where
+       -- g :: (s1 ~# s2) ~# (t1 ~#  t2)
+       -- g1 :: s1 ~# t1
+       -- g2 :: s2 ~# t2
+       new_co = mkSymCo g1 `mkTransCo` e_co `mkTransCo` g2
+       [_reflk, g1, g2] = decomposeCo 3 co
+            -- Remember, (~#) :: forall k. k -> k -> *
+            -- so it takes *three* arguments, not two
+
+mkCast (Cast expr co2) co
   = ASSERT(let { Pair  from_ty  _to_ty  = coercionKind co;
                  Pair _from_ty2  to_ty2 = coercionKind co2} in
            from_ty `eqType` to_ty2 )
-    mkCoerce (mkTransCo co2 co) expr
+    mkCast expr (mkTransCo co2 co)
 
-mkCoerce co expr
+mkCast expr co
   = let Pair from_ty _to_ty = coercionKind co in
 --    if to_ty `eqType` from_ty
 --    then expr
@@ -1504,7 +1517,7 @@ tryEtaReduce bndrs body
     -- See Note [Eta reduction with casted arguments]
     -- for why we have an accumulating coercion
     go [] fun co
-      | ok_fun fun = Just (mkCoerce co fun)
+      | ok_fun fun = Just (mkCast fun co)
 
     go (b : bs) (App fun arg) co
       | Just co' <- ok_arg b arg co
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index a9701ff185..e88b57e835 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -153,16 +153,21 @@ deSugar hsc_env
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
         -- Lint result if necessary, and print
+{-
         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
                (vcat [ pprCoreBindings final_pgm
                      , pprRules rules_for_imps ])
+-}
 
+#ifdef DEBUG
+        ; endPass dflags CoreDesugar final_pgm rules_for_imps 
+#endif
         ; (ds_binds, ds_rules_for_imps, ds_vects) 
             <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
                          -- The simpleOptPgm gets rid of type 
                          -- bindings plus any stupid dead code
 
-        ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
+        ; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
         ; deps <- mkDependencies tcg_env
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index f3be1964a8..46c93781f2 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -186,10 +186,14 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
 --------------------------------------
 dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"	-- Zonker has got rid of this
-dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+dsTcEvBinds (EvBinds bs)   = -- pprTrace "EvBinds bs = "  (ppr bs) $ 
+                             dsEvBinds bs
 
 dsEvBinds :: Bag EvBind -> DsM [CoreBind]
-dsEvBinds bs = return (map dsEvGroup sccs)
+dsEvBinds bs = do { let core_binds = map dsEvSCC sccs 
+--                   ; pprTrace "dsEvBinds, result = " (vcat (map ppr core_binds)) $ 
+                  ; return core_binds }
+--                   ; return (map dsEvGroup sccs)
   where
     sccs :: [SCC EvBind]
     sccs = stronglyConnCompFromEdgedVertices edges
@@ -202,19 +206,19 @@ dsEvBinds bs = return (map dsEvGroup sccs)
 
     free_vars_of :: EvTerm -> [EvVar]
     free_vars_of (EvId v)           = [v]
-    free_vars_of (EvCast v co)      = v : varSetElems (tyCoVarsOfCo co)
-    free_vars_of (EvCoercionBox co) = varSetElems (tyCoVarsOfCo co)
+    free_vars_of (EvCast v co)      = v : varSetElems (coVarsOfCo co)
+    free_vars_of (EvCoercionBox co) = varSetElems (coVarsOfCo co)
     free_vars_of (EvDFunApp _ _ vs) = vs
     free_vars_of (EvTupleSel v _)   = [v]
     free_vars_of (EvTupleMk vs)     = vs
     free_vars_of (EvSuperClass d _) = [d]
 
-dsEvGroup :: SCC EvBind -> CoreBind
+dsEvSCC :: SCC EvBind -> CoreBind
 
-dsEvGroup (AcyclicSCC (EvBind v r))
+dsEvSCC (AcyclicSCC (EvBind v r))
   = NonRec v (dsEvTerm r)
 
-dsEvGroup (CyclicSCC bs)
+dsEvSCC (CyclicSCC bs)
   = Rec (map ds_pair bs)
   where
     ds_pair (EvBind v r) = (v, dsEvTerm r)
@@ -251,8 +255,12 @@ dsLCoercion co k
 
 ---------------------------------------
 dsEvTerm :: EvTerm -> CoreExpr
-dsEvTerm (EvId v)                = Var v
-dsEvTerm (EvCast v co)           = dsLCoercion co $ Cast (Var v)
+dsEvTerm (EvId v) = Var v
+
+dsEvTerm (EvCast v co) 
+  = dsLCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
+                                    -- unnecessary to call varToCoreExpr v here.
+
 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
 dsEvTerm (EvCoercionBox co)      = dsLCoercion co mkEqBox
 dsEvTerm (EvTupleSel v n)
@@ -686,12 +694,13 @@ dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
 dsHsWrapper WpHole 	      = return (\e -> e)
 dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
 dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+--                                   ; pprTrace "Desugared core bindings = " (vcat (map ppr ds_ev_binds)) $ 
                                    ; return (mkCoreLets ds_ev_binds) }
 dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
                                    ; k2 <- dsHsWrapper c2
                                    ; return (k1 . k2) }
 dsHsWrapper (WpCast co)
-  = return (\e -> dsLCoercion co (Cast e)) 
+  = return (\e -> dsLCoercion co (mkCast e)) 
 dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
 dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
 dsHsWrapper (WpEvApp evtrm)
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 79412b576c..06a41bcd1a 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -142,7 +142,7 @@ unboxArg arg
 
   -- Recursive newtypes
   | Just(_rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
-  = unboxArg (mkCoerce co arg)
+  = unboxArg (mkCast arg co)
       
   -- Booleans
   | Just tc <- tyConAppTyCon_maybe arg_ty, 
@@ -342,7 +342,7 @@ resultWrapper result_ty
   -- Recursive newtypes
   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
   = do (maybe_ty, wrapper) <- resultWrapper rep_ty
-       return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e))
+       return (maybe_ty, \e -> mkCast (wrapper e) (mkSymCo co))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index a394a0f5de..626b6ee795 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -642,7 +642,7 @@ mkSelectorBinds ticks pat val_expr
                                 (Var bndr_var) error_expr
         return (bndr_var, mkOptTickBox tick rhs_expr)
       where
-        error_expr = mkCoerce co (Var err_var)
+        error_expr = mkCast (Var err_var) co
         co         = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
 
     is_simple_lpat p = is_simple_pat (unLoc p)
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index c3728788f1..b6bc0c702b 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -486,19 +486,21 @@ data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
      -- The Unique is only for debug printing
 
 -----------------
-type EvBindMap = VarEnv EvBind
+newtype EvBindMap = EvBindMap { ev_bind_varenv :: VarEnv EvBind } -- Map from evidence variables to evidence terms
 
 emptyEvBindMap :: EvBindMap
-emptyEvBindMap = emptyVarEnv
+emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv }
 
 extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
-extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
+extendEvBinds bs v t 
+  = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) }
 
 lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
-lookupEvBind = lookupVarEnv
+lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs)
 
 evBindMapBinds :: EvBindMap -> Bag EvBind
-evBindMapBinds = foldVarEnv consBag emptyBag
+evBindMapBinds bs 
+  = foldVarEnv consBag emptyBag (ev_bind_varenv bs)
 
 -----------------
 instance Data TcEvBinds where
@@ -551,6 +553,11 @@ Conclusion: a new wanted coercion variable should be made mutable.
 
 
 \begin{code}
+mkEvCast :: EvVar -> LCoercion -> EvTerm
+mkEvCast ev lco
+  | isReflCo lco = EvId ev
+  | otherwise    = EvCast ev lco
+
 emptyTcEvBinds :: TcEvBinds
 emptyTcEvBinds = EvBinds emptyBag
 
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index e97f462dcc..5cb07a14da 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -242,7 +242,17 @@ funTyConName :: Name
 funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
 
 funTyCon :: TyCon
-funTyCon = mkFunTyCon funTyConName (mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind)
+funTyCon = mkFunTyCon funTyConName $ 
+           mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
+        -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
+	-- But if we do that we get kind errors when saying
+	--	instance Control.Arrow (->)
+	-- becuase the expected kind is (*->*->*).  The trouble is that the
+	-- expected/actual stuff in the unifier does not go contra-variant, whereas
+	-- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
+	-- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
+        -- because they are never in scope in the source
+
 -- One step to remove subkinding.
 -- (->) :: * -> * -> *
 -- but we should have (and want) the following typing rule for fully applied arrows
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 950c6a9a75..1e4def3f14 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -251,8 +251,9 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
-  | CoreDesugar	 -- Not strictly a core-to-core pass, but produces
-                 -- Core output, and hence useful to pass to endPass
+  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!
+  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces
+                       --                 Core output, and hence useful to pass to endPass
 
   | CoreTidy
   | CorePrep
@@ -274,6 +275,7 @@ coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
 coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
 coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds 
+coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds 
 coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
 coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 
@@ -295,7 +297,8 @@ instance Outputable CoreToDo where
   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
   ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
-  ppr CoreDesugar              = ptext (sLit "Desugar")
+  ppr CoreDesugar              = ptext (sLit "Desugar (before optimization)")
+  ppr CoreDesugarOpt           = ptext (sLit "Desugar (after optimization)")
   ppr CoreTidy                 = ptext (sLit "Tidy Core")
   ppr CorePrep 		       = ptext (sLit "CorePrep")
   ppr CoreDoPrintCore          = ptext (sLit "Print core")
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 65a6927be7..8056c0eceb 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -28,7 +28,7 @@ module OccurAnal (
 
 import CoreSyn
 import CoreFVs
-import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce )
+import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCast )
 import Id
 import Name( localiseName )
 import BasicTypes
@@ -1345,7 +1345,7 @@ wrapProxy (bndr, rhs_var, co) (body_usg, body)
   where
     (body_usg', tagged_bndr) = tagBinder body_usg bndr
     rhs_usg = unitVarEnv rhs_var NoOccInfo	-- We don't need exact info
-    rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings]
+    rhs = mkCast (Var (zapIdOccInfo rhs_var)) co -- See Note [Zap case binders in proxy bindings]
 \end{code}
 
 
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 3c4091650c..86dc88ddd1 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -1062,7 +1062,7 @@ mkLam _env bndrs body
       | not (any bad bndrs)
 	-- Note [Casts and lambdas]
       = do { lam <- mkLam' dflags bndrs body
-           ; return (mkCoerce (mkPiCos bndrs co) lam) }
+           ; return (mkCast lam (mkPiCos bndrs co)) }
       where
         co_vars  = tyCoVarsOfCo co
 	bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars      
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 2e4227132f..a8f7761e61 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -983,26 +983,12 @@ simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
 --  =  Coercion (syn (nth 0 g) ; co ; nth 1 g) 
 simplCoercionF env co cont 
   = do { co' <- simplCoercion env co
-       ; simpl_co co' cont }
-  where
-    simpl_co co (CoerceIt g cont)
-       = simpl_co new_co cont
-     where
-       -- g :: (s1 ~# s2) ~# (t1 ~#  t2)
-       -- g1 :: s1 ~# t1
-       -- g2 :: s2 ~# t2
-       new_co = mkSymCo g1 `mkTransCo` co `mkTransCo` g2
-       [_reflk, g1, g2] = decomposeCo 3 g
-            -- Remember, (~#) :: forall k. k -> k -> *
-            -- so it takes *three* arguments, not two
-
-    simpl_co co cont
-       = seqCo co `seq` rebuild env (Coercion co) cont
+       ; rebuild env (Coercion co') cont }
 
 simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
 simplCoercion env co
   = let opt_co = optCoercion (getCvSubst env) co
-    in opt_co `seq` return opt_co
+    in seqCo opt_co `seq` return opt_co
 
 -----------------------------------
 -- | Push a TickIt context outwards past applications and cases, as
@@ -1162,7 +1148,8 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 rebuild env expr cont
   = case cont of
       Stop {}                      -> return (env, expr)
-      CoerceIt co cont             -> rebuild env (Cast expr co) cont
+      CoerceIt co cont             -> rebuild env (mkCast expr co) cont 
+                                         -- NB: mkCast implements the (Coercion co |> g) optimisation
       Select _ bndr alts se cont   -> rebuildCase (se `setFloats` env) expr bndr alts cont
       StrictArg info _ cont        -> rebuildCall env (info `addArgTo` expr) cont
       StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
@@ -1242,7 +1229,7 @@ simplCast env body co0 cont0
            -- t2 ~ s2 with left and right on the curried form:
            --    (->) t1 t2 ~ (->) s1 s2
            [co1, co2] = decomposeCo 2 co
-           new_arg    = mkCoerce (mkSymCo co1) arg'
+           new_arg    = mkCast arg' (mkSymCo co1)
            arg'       = substExpr (text "move-cast") arg_se' arg
            arg_se'    = arg_se `setInScope` env
 
@@ -1447,7 +1434,7 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
     cont_ty = contResultType env res_ty cont
     co      = mkUnsafeCo res_ty cont_ty
     mk_coerce expr | cont_ty `eqType` res_ty = expr
-                   | otherwise = mkCoerce co expr
+                   | otherwise = mkCast expr co
 
 rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
   = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 5a59750167..40d0d2b3c5 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -29,12 +29,13 @@ module Inst (
        
        tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX,
        tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
+       tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts,
 
        tidyWantedEvVar, tidyWantedEvVars, tidyWC,
-       tidyEvVar, tidyImplication, tidyFlavoredEvVar,
+       tidyEvVar, tidyImplication, tidyCt,
 
-       substWantedEvVar, substWantedEvVars, substFlavoredEvVar,
-       substEvVar, substImplication
+       substWantedEvVar, substWantedEvVars,
+       substEvVar, substImplication, substCt
     ) where
 
 #include "HsVersions.h"
@@ -512,20 +513,39 @@ hasEqualities :: [EvVar] -> Bool
 -- Has a bunch of canonical constraints (all givens) got any equalities in it?
 hasEqualities givens = any (has_eq . evVarPred) givens
   where
-    has_eq = has_eq' . predTypePredTree
+    has_eq = has_eq' . classifyPredType
 
     has_eq' (EqPred {})          = True
     has_eq' (IPPred {})          = False
     has_eq' (ClassPred cls _tys) = any has_eq (classSCTheta cls)
-    has_eq' (TuplePred ts)       = any has_eq' ts
+    has_eq' (TuplePred ts)       = any has_eq ts
     has_eq' (IrredPred _)        = True -- Might have equalities in it after reduction?
 
 ---------------- Getting free tyvars -------------------------
+
+tyVarsOfCt :: Ct -> TcTyVarSet
+tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
+tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
+tyVarsOfCt (CDictCan { cc_tyargs = tys }) 	        = tyVarsOfTypes tys
+tyVarsOfCt (CIPCan { cc_ip_ty = ty })                   = tyVarsOfType ty
+tyVarsOfCt (CIrredEvCan { cc_ty = ty })                 = tyVarsOfType ty
+tyVarsOfCt (CNonCanonical { cc_id = ev })               = tyVarsOfEvVar ev
+
+tyVarsOfCDict :: Ct -> TcTyVarSet 
+tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
+tyVarsOfCDict _ct                            = emptyVarSet 
+
+tyVarsOfCDicts :: Cts -> TcTyVarSet 
+tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet
+
+tyVarsOfCts :: Cts -> TcTyVarSet
+tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
+
 tyVarsOfWC :: WantedConstraints -> TyVarSet
 tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
-  = tyVarsOfEvVarXs flat `unionVarSet`
+  = tyVarsOfCts flat `unionVarSet`
     tyVarsOfBag tyVarsOfImplication implic `unionVarSet`
-    tyVarsOfEvVarXs insol
+    tyVarsOfCts insol
 
 tyVarsOfImplication :: Implication -> TyVarSet
 tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted })
@@ -547,11 +567,19 @@ tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
 
 ---------------- Tidying -------------------------
+
+tidyCt :: TidyEnv -> Ct -> Ct
+-- Also converts it to non-canonical
+tidyCt env ct 
+  = CNonCanonical { cc_id     = tidyEvVar env (cc_id ct)
+                  , cc_flavor = tidyFlavor env (cc_flavor ct)
+                  , cc_depth  = cc_depth ct } 
+
 tidyWC :: TidyEnv -> WantedConstraints -> WantedConstraints
 tidyWC env (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
-  = WC { wc_flat  = tidyWantedEvVars env flat
+  = WC { wc_flat  = mapBag (tidyCt env) flat
        , wc_impl  = mapBag (tidyImplication env) implic
-       , wc_insol = mapBag (tidyFlavoredEvVar env) insol }
+       , wc_insol = mapBag (tidyCt env) insol }
 
 tidyImplication :: TidyEnv -> Implication -> Implication
 tidyImplication env implic@(Implic { ic_skols = tvs
@@ -574,9 +602,6 @@ tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l
 tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
 tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
 
-tidyFlavoredEvVar :: TidyEnv -> FlavoredEvVar -> FlavoredEvVar
-tidyFlavoredEvVar env (EvVarX v fl)
-  = EvVarX (tidyEvVar env v) (tidyFlavor env fl)
 
 tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
 tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
@@ -591,11 +616,24 @@ tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
 tidySkolemInfo _   info            = info
 
 ---------------- Substitution -------------------------
+substCt :: TvSubst -> Ct -> Ct 
+-- Conservatively converts it to non-canonical:
+-- Postcondition: if the constraint does not get rewritten
+substCt subst ct
+  | ev <- cc_id ct, pty <- evVarPred (cc_id ct) 
+  , sty <- substTy subst pty 
+  = if sty `eqType` pty then 
+        ct { cc_flavor = substFlavor subst (cc_flavor ct) }
+    else 
+        CNonCanonical { cc_id  = setVarType ev sty 
+                      , cc_flavor = substFlavor subst (cc_flavor ct)
+                      , cc_depth  = cc_depth ct }
+
 substWC :: TvSubst -> WantedConstraints -> WantedConstraints
 substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
-  = WC { wc_flat = substWantedEvVars subst flat
-       , wc_impl = mapBag (substImplication subst) implic
-       , wc_insol = mapBag (substFlavoredEvVar subst) insol }
+  = WC { wc_flat  = mapBag (substCt subst) flat
+       , wc_impl  = mapBag (substImplication subst) implic
+       , wc_insol = mapBag (substCt subst) insol }
 
 substImplication :: TvSubst -> Implication -> Implication
 substImplication subst implic@(Implic { ic_skols = tvs
@@ -618,9 +656,6 @@ substWantedEvVars subst = mapBag (substWantedEvVar subst)
 substWantedEvVar :: TvSubst -> WantedEvVar -> WantedEvVar
 substWantedEvVar subst (EvVarX v l) = EvVarX (substEvVar subst v) l
 
-substFlavoredEvVar :: TvSubst -> FlavoredEvVar -> FlavoredEvVar
-substFlavoredEvVar subst (EvVarX v fl)
-  = EvVarX (substEvVar subst v) (substFlavor subst fl)
 
 substFlavor :: TvSubst -> CtFlavor -> CtFlavor
 substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index dac7d8816f..d5e1f75b8d 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -7,14 +7,16 @@
 -- for details
 
 module TcCanonical(
-    mkCanonical, mkCanonicals, mkCanonicalFEV, mkCanonicalFEVs, canWanteds, canGivens,
-    canOccursCheck, canEqToWorkList,
-    rewriteWithFunDeps, mkCanonicalFDAsDerived, mkCanonicalFDAsWanted
+    canonicalize,
+    canOccursCheck, canEq, canEvVar,
+    rewriteWithFunDeps,
+    emitFDWorkAsWanted, emitFDWorkAsDerived,
+    StopOrContinue (..)
  ) where
 
 #include "HsVersions.h"
 
-import BasicTypes
+import BasicTypes ( IPName )
 import TcErrors
 import TcRnTypes
 import FunDeps
@@ -26,265 +28,289 @@ import Coercion
 import Class
 import TyCon
 import TypeRep
-import Name
+import Name ( Name )
 import Var
-import VarEnv		( TidyEnv )
+import VarEnv
 import Outputable
-import Control.Monad    ( unless, when, zipWithM, zipWithM_, foldM, liftM, forM )
+import Control.Monad    ( when, unless, zipWithM, zipWithM_, foldM )
 import MonadUtils
 import Control.Applicative ( (<|>) )
 
+import TrieMap
 import VarSet
-import Bag
-
 import HsBinds
 import TcSMonad
 import FastString
-\end{code}
 
-Note [Canonicalisation]
-~~~~~~~~~~~~~~~~~~~~~~~
-* Converts (Constraint f) _which_does_not_contain_proper_implications_ to CanonicalCts
-* Unary: treats individual constraints one at a time
-* Does not do any zonking
-* Lives in TcS monad so that it can create new skolem variables
+import Data.Maybe ( isNothing )
+import Pair ( pSnd )
+
+\end{code}
 
 
 %************************************************************************
 %*                                                                      *
-%*        Flattening (eliminating all function symbols)                 *
+%*                      The Canonicaliser                               *
 %*                                                                      *
 %************************************************************************
 
-Note [Flattening]
-~~~~~~~~~~~~~~~~~~~~
-  flatten ty  ==>   (xi, cc)
-    where
-      xi has no type functions
-      cc = Auxiliary given (equality) constraints constraining
-           the fresh type variables in xi.  Evidence for these 
-           is always the identity coercion, because internally the
-           fresh flattening skolem variables are actually identified
-           with the types they have been generated to stand in for.
-
-Note that it is flatten's job to flatten *every type function it sees*.
-flatten is only called on *arguments* to type functions, by canEqGiven.
+Note [Canonicalization]
+~~~~~~~~~~~~~~~~~~~~~~~
 
-Recall that in comments we use alpha[flat = ty] to represent a
-flattening skolem variable alpha which has been generated to stand in
-for ty.
+Canonicalization converts a flat constraint to a canonical form. It is
+unary (i.e. treats individual constraints one at a time), does not do
+any zonking, but lives in TcS monad because it needs to create fresh
+variables (for flattening) and consult the inerts (for efficiency).
 
------ Example of flattening a constraint: ------
-  flatten (List (F (G Int)))  ==>  (xi, cc)
-    where
-      xi  = List alpha
-      cc  = { G Int ~ beta[flat = G Int],
-              F beta ~ alpha[flat = F beta] }
-Here
-  * alpha and beta are 'flattening skolem variables'.
-  * All the constraints in cc are 'given', and all their coercion terms 
-    are the identity.
+The execution plan for canonicalization is the following:
+ 
+  1) Decomposition of equalities happens as necessary until we reach a 
+     variable or type family in one side. There is no decomposition step
+     for other forms of constraints. 
 
-NB: Flattening Skolems only occur in canonical constraints, which
-are never zonked, so we don't need to worry about zonking doing
-accidental unflattening.
+  2) If, when we decompose, we discover a variable on the head then we 
+     look at inert_eqs from the current inert for a substitution for this 
+     variable and contine decomposing. Hence we lazily apply the inert 
+     substitution if it is needed. 
 
-Note that we prefer to leave type synonyms unexpanded when possible,
-so when the flattener encounters one, it first asks whether its
-transitive expansion contains any type function applications.  If so,
-it expands the synonym and proceeds; if not, it simply returns the
-unexpanded synonym.
+  3) If no more decomposition is possible, we deeply apply the substitution
+     from the inert_eqs and continue with flattening.
 
-TODO: caching the information about whether transitive synonym
-expansions contain any type function applications would speed things
-up a bit; right now we waste a lot of energy traversing the same types
-multiple times.
+  4) During flattening, we examine whether we have already flattened some 
+     function application by looking at all the CTyFunEqs with the same 
+     function in the inert set. The reason for deeply applying the inert 
+     substitution at step (3) is to maximise our chances of matching an 
+     already flattened family application in the inert. 
 
+The net result is that a constraint coming out of the canonicalization 
+phase cannot be rewritten any further from the inerts (but maybe /it/ can 
+rewrite an inert or still interact with an inert in a further phase in the
+simplifier.
 
 \begin{code}
 
--- Flatten a bunch of types all at once.
-flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [LCoercion], CanonicalCts)
--- Coercions :: Xi ~ Type 
-flattenMany ctxt tys 
-  = do { (xis, cos, cts_s) <- mapAndUnzip3M (flatten ctxt) tys
-       ; return (xis, cos, andCCans cts_s) }
-
--- Flatten a type to get rid of type function applications, returning
--- the new type-function-free type, and a collection of new equality
--- constraints.  See Note [Flattening] for more detail.
-flatten :: CtFlavor -> TcType -> TcS (Xi, LCoercion, CanonicalCts)
--- Postcondition: Coercion :: Xi ~ TcType
--- Postcondition: CanonicalCts are all CFunEqCan
-flatten ctxt ty 
-  | Just ty' <- tcView ty
-  = do { (xi, co, ccs) <- flatten ctxt ty'
-	-- Preserve type synonyms if possible
-	-- We can tell if ty' is function-free by
-	-- whether there are any floated constraints
-       ; if isReflCo co then
-             return (ty, mkReflCo ty, emptyCCan)
-         else
-             return (xi, co, ccs) }
-
-flatten _ v@(TyVarTy _)
-  = return (v, mkReflCo v, emptyCCan)
+-- Informative results of canonicalization
+data StopOrContinue 
+  = ContinueWith Ct   -- Either no canonicalization happened, or if some did 
+                      -- happen, it is still safe to just keep going with this 
+                      -- work item. 
+  | Stop              -- Some canonicalization happened, extra work is now in 
+                      -- the TcS WorkList. 
 
-flatten ctxt (AppTy ty1 ty2)
-  = do { (xi1,co1,c1) <- flatten ctxt ty1
-       ; (xi2,co2,c2) <- flatten ctxt ty2
-       ; return (mkAppTy xi1 xi2, mkAppCo co1 co2, c1 `andCCan` c2) }
+instance Outputable StopOrContinue where
+  ppr Stop             = ptext (sLit "Stop")
+  ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w
 
-flatten ctxt (FunTy ty1 ty2)
-  = do { (xi1,co1,c1) <- flatten ctxt ty1
-       ; (xi2,co2,c2) <- flatten ctxt ty2
-       ; return (mkFunTy xi1 xi2, mkFunCo co1 co2, c1 `andCCan` c2) }
 
-flatten fl (TyConApp tc tys)
-  -- For a normal type constructor or data family application, we just
-  -- recursively flatten the arguments.
-  | not (isSynFamilyTyCon tc)
-    = do { (xis,cos,ccs) <- flattenMany fl tys
-         ; return (mkTyConApp tc xis, mkTyConAppCo tc cos, ccs) }
+continueWith :: Ct -> TcS StopOrContinue
+continueWith = return . ContinueWith
 
-  -- Otherwise, it's a type function application, and we have to
-  -- flatten it away as well, and generate a new given equality constraint
-  -- between the application and a newly generated flattening skolem variable.
-  | otherwise
-  = ASSERT( tyConArity tc <= length tys )	-- Type functions are saturated
-      do { (xis, cos, ccs) <- flattenMany fl tys
-         ; let (xi_args, xi_rest)  = splitAt (tyConArity tc) xis
-	       	 -- The type function might be *over* saturated
-		 -- in which case the remaining arguments should
-		 -- be dealt with by AppTys
-               fam_ty = mkTyConApp tc xi_args
-         ; (ret_eqv, rhs_var, ct) <-
-             do { is_cached <- lookupFlatCacheMap tc xi_args fl 
-                ; case is_cached of 
-                    Just (rhs_var,ret_eqv,_fl) -> return (ret_eqv, rhs_var, emptyCCan)
-                    Nothing
-                        | isGivenOrSolved fl ->
-                            do { rhs_var <- newFlattenSkolemTy fam_ty
-                               ; eqv <- newGivenEqVar fam_ty rhs_var (mkReflCo fam_ty)
-                               ; let ct = CFunEqCan { cc_id     = eqv
-                                                    , cc_flavor = fl -- Given
-                                                    , cc_fun    = tc 
-                                                    , cc_tyargs = xi_args 
-                                                    , cc_rhs    = rhs_var }
-                               ; updateFlatCacheMap tc xi_args rhs_var fl eqv 
-                               ; return (eqv, rhs_var, singleCCan ct) }
-                        | otherwise ->
-                    -- Derived or Wanted: make a new *unification* flatten variable
-                            do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
-                               ; eqv <- newEqVar fam_ty rhs_var
-                               ; let ct = CFunEqCan { cc_id = eqv
-                                                    , cc_flavor = mkWantedFlavor fl
-                                                    -- Always Wanted, not Derived
-                                                    , cc_fun = tc
-                                                    , cc_tyargs = xi_args
-                                                    , cc_rhs    = rhs_var }
-                               ; updateFlatCacheMap tc xi_args rhs_var fl eqv
-                               ; return (eqv, rhs_var, singleCCan ct) } }
-         ; let ret_co = mkEqVarLCo ret_eqv
-               (cos_args, cos_rest) = splitAt (tyConArity tc) cos
-         ; return ( foldl AppTy rhs_var xi_rest
-                  , foldl AppCo (mkSymCo ret_co `mkTransCo` mkTyConAppCo tc cos_args)
-                                cos_rest
-                  , ccs `andCCan` ct) }
+andWhenContinue :: TcS StopOrContinue 
+                -> (Ct -> TcS StopOrContinue) 
+                -> TcS StopOrContinue
+andWhenContinue tcs1 tcs2
+  = do { r <- tcs1
+       ; case r of
+           Stop            -> return Stop
+           ContinueWith ct -> tcs2 ct }
 
-flatten ctxt ty@(ForAllTy {})
--- We allow for-alls when, but only when, no type function
--- applications inside the forall involve the bound type variables
--- TODO: What if it is a (t1 ~ t2) => t3
---       Must revisit when the New Coercion API is here! 
-  = do { let (tvs, rho) = splitForAllTys ty
-       ; (rho', co, ccs) <- flatten ctxt rho
-       ; let bad_eqs  = filterBag is_bad ccs
-             is_bad c = tyVarsOfCanonical c `intersectsVarSet` tv_set
-             tv_set   = mkVarSet tvs
-       ; unless (isEmptyBag bad_eqs)
-                (flattenForAllErrorTcS ctxt ty bad_eqs)
-       ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, ccs)  }
 \end{code}
 
-%************************************************************************
-%*                                                                      *
-%*                Canonicalising given constraints                      *
-%*                                                                      *
-%************************************************************************
+Note [Caching for canonicals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+Our plan with pre-canonicalization is to be able to solve a constraint really fast from existing
+bindings in TcEvBinds. So one may think that the condition (isCNonCanonical) is not necessary. 
+However consider the following setup:
 
-\begin{code}
-canWanteds :: [WantedEvVar] -> TcS WorkList
-canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev)
+InertSet = { [W] d1 : Num t } 
+WorkList = { [W] d2 : Num t, [W] c : t ~ Int} 
 
-canGivens :: GivenLoc -> [EvVar] -> TcS WorkList
-canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens
-                          ; return (unionWorkLists ccs) }
+Now, we prioritize equalities, but in our concrete example (should_run/mc17.hs) the first (d2) constraint 
+is dealt with first, because (t ~ Int) is an equality that only later appears in the worklist since it is
+pulled out from a nested implication constraint. So, let's examine what happens:
+ 
+   - We encounter work item (d2 : Num t)
+
+   - Nothing is yet in EvBinds, so we reach the interaction with inerts 
+     and set:
+              d2 := d1 
+    and we discard d2 from the worklist. The inert set remains unaffected.
+
+   - Now the equation ([W] c : t ~ Int) is encountered and kicks-out (d1 : Num t) from the inerts.
+     Then that equation gets spontaneously solved, perhaps. We end up with:
+        InertSet : { [G] c : t ~ Int }
+        WorkList : { [W] d1 : Num t} 
+
+   - Now we examine (d1), we observe that there is a binding for (Num t) in the evidence binds and 
+     we set: 
+             d1 := d2 
+     and end up in a loop!
+
+Now, the constraints that get kicked out from the inert set are always Canonical, so by restricting
+the use of the pre-canonicalizer to NonCanonical constraints we eliminate this danger. Moreover, for 
+canonical constraints we already have good caching mechanisms (effectively the interaction solver) 
+and we are interested in reducing things like superclasses of the same non-canonical constraint being 
+generated hence I don't expect us to lose a lot by introducing the (isCNonCanonical) restriction.
+
+A similar situation can arise in TcSimplify, at the end of the solve_wanteds function, where constraints
+from the inert set are returned as new work -- our substCt ensures however that if they are not rewritten
+by subst, they remain canonical and hence we will not attempt to solve them from the EvBinds. If on the 
+other hand they did get rewritten and are now non-canonical they will still not match the EvBinds, so we 
+are again good.
 
-mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList
-mkCanonicals fl vs = fmap unionWorkLists (mapM (mkCanonical fl) vs)
+\begin{code}
 
-mkCanonicalFEV :: FlavoredEvVar -> TcS WorkList
-mkCanonicalFEV (EvVarX ev fl) = mkCanonical fl ev
+-- Top-level canonicalization
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+canonicalize :: Ct -> TcS StopOrContinue
+canonicalize ct@(CNonCanonical { cc_id = ev, cc_flavor = fl, cc_depth  = d })
+  = do { traceTcS "canonicalize (non-canonical)" (ppr ct)
+       ; canEvVar ev (classifyPredType (evVarPred ev)) d fl }
+
+canonicalize (CDictCan { cc_id = ev, cc_depth = d
+                       , cc_flavor = fl
+                       , cc_class  = cls
+                       , cc_tyargs = xis })
+  = canClass d fl ev cls xis -- Do not add any superclasses
+canonicalize (CTyEqCan { cc_id = ev, cc_depth = d
+                       , cc_flavor = fl
+                       , cc_tyvar  = tv
+                       , cc_rhs    = xi })
+  = canEqLeafTyVarLeftRec d fl ev tv xi
+
+canonicalize (CFunEqCan { cc_id = ev, cc_depth = d
+                        , cc_flavor = fl
+                        , cc_fun    = fn
+                        , cc_tyargs = xis1
+                        , cc_rhs    = xi2 })
+  = canEqLeafFunEqLeftRec d fl ev (fn,xis1) xi2
+
+canonicalize (CIPCan { cc_id = ev, cc_depth = d
+                     , cc_flavor = fl
+                     , cc_ip_nm  = nm
+                     , cc_ip_ty  = xi })
+  = canIP d fl ev nm xi
+canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl
+                          , cc_depth = d
+                          , cc_ty = xi })
+  = canIrred d fl ev xi
+
+
+canEvVar :: EvVar -> PredTree 
+         -> SubGoalDepth -> CtFlavor -> TcS StopOrContinue
+canEvVar ev pred_classifier d fl 
+  = case pred_classifier of
+      ClassPred cls tys -> canClass d fl ev cls tys 
+                                        `andWhenContinue` emit_superclasses
+      EqPred ty1 ty2    -> canEq    d fl ev ty1 ty2
+      IPPred nm ty      -> canIP    d fl ev nm ty
+      IrredPred ev_ty   -> canIrred d fl ev ev_ty
+      TuplePred tys     -> canTuple d fl ev tys
+  where emit_superclasses ct@(CDictCan {cc_id = v_new
+                                       , cc_tyargs = xis_new, cc_class = cls })
+            -- Add superclasses of this one here, See Note [Adding superclasses]. 
+            -- But only if we are not simplifying the LHS of a rule. 
+          = do { sctxt <- getTcSContext
+               ; unless (simplEqsOnly sctxt) $ 
+                        newSCWorkFromFlavored d v_new fl cls xis_new
+               ; continueWith ct }
+        emit_superclasses _ = panic "emit_superclasses of non-class!"
+
+
+-- Tuple canonicalisation
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+canTuple :: SubGoalDepth -- Depth 
+         -> CtFlavor -> EvVar -> [PredType] -> TcS StopOrContinue
+canTuple d fl ev tys
+  = do { traceTcS "can_pred" (text "TuplePred!") 
+       ; evs <- zipWithM can_pred_tup_one tys [0..]
+       ; when (isWanted fl) $ setEvBind ev (EvTupleMk evs)
+       ; return Stop }
+  where 
+     can_pred_tup_one ty n
+          = do { evc <- newEvVar fl ty
+               ; let ev' = evc_the_evvar evc 
+               ; when (isGivenOrSolved fl) $ 
+                      setEvBind ev' (EvTupleSel ev n)
+               ; when (isNewEvVar evc)     $ 
+                      addToWork (canEvVar ev' (classifyPredType (evVarPred ev')) d fl)
+               ; return ev' }
+
+-- Implicit Parameter Canonicalization
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+canIP :: SubGoalDepth -- Depth 
+      -> CtFlavor -> EvVar 
+      -> IPName Name -> Type -> TcS StopOrContinue
+-- Precondition: EvVar is implicit parameter evidence
+canIP d fl v nm ty
+  =    -- Note [Canonical implicit parameter constraints] explains why it's 
+       -- possible in principle to not flatten, but since flattening applies 
+       -- the inert substitution we choose to flatten anyway.
+    do { (xi,co) <- flatten d fl (mkIPPred nm ty)
+       ; if isReflCo co then
+             continueWith $ CIPCan { cc_id = v, cc_flavor = fl
+                                   , cc_ip_nm = nm, cc_ip_ty = ty
+                                   , cc_depth = d }
+         else do { evc <- newEvVar fl xi
+                 ; let v_new          = evc_the_evvar evc
+                       IPPred _ ip_xi = classifyPredType xi
+                 ; case fl of 
+                     Wanted {}  -> setEvBind v (EvCast v_new co)
+                     Given {}   -> setEvBind v_new (EvCast v (mkSymCo co))
+                     Derived {} -> return ()
+                 ; if isNewEvVar evc then
+                       continueWith $ CIPCan { cc_id     = v_new
+                                             , cc_flavor = fl, cc_ip_nm = nm
+                                             , cc_ip_ty  = ip_xi
+                                             , cc_depth  = d }
+                   else return Stop } }
+\end{code}
 
-mkCanonicalFEVs :: Bag FlavoredEvVar -> TcS WorkList
-mkCanonicalFEVs = foldrBagM canon_one emptyWorkList
-  where 	-- Preserves order (shouldn't be important, but curently
-  		--                  is important for the vectoriser)
-    canon_one fev wl = do { wl' <- mkCanonicalFEV fev
-                          ; return (unionWorkList wl' wl) }
+Note [Canonical implicit parameter constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type in a canonical implicit parameter constraint doesn't need to
+be a xi (type-function-free type) since we can defer the flattening
+until checking this type for equality with another type.  If we
+encounter two IP constraints with the same name, they MUST have the
+same type, and at that point we can generate a flattened equality
+constraint between the types.  (On the other hand, the types in two
+class constraints for the same class MAY be equal, so they need to be
+flattened in the first place to facilitate comparing them.)
+\begin{code}
 
-mkCanonical :: CtFlavor -> EvVar -> TcS WorkList
-mkCanonical fl ev = go ev (predTypePredTree (evVarPred ev))
-  where
-    go ev (ClassPred clas tys) = canClassToWorkList fl ev clas tys
-    go ev (EqPred ty1 ty2)     = canEqToWorkList    fl ev ty1 ty2
-    go ev (IPPred ip ty)       = canIPToWorkList    fl ev ip ty
-    go ev (TuplePred tys)      = do
-      (mb_evs', wlists) <- liftM unzip $ forM (tys `zip` [0..]) $ \(ty, n) -> do
-        ev' <- newEvVar (predTreePredType ty)
-        mb_ev <- case fl of 
-           Wanted {}  -> return (Just ev')
-           Given {}   -> setEvBind ev' (EvTupleSel ev n) >> return Nothing
-           Derived {} -> return Nothing -- Derived ips: we don't set any evidence
-
-        liftM ((,) mb_ev) $ go ev' ty
-
-      -- If we Wanted this TuplePred we have to bind it from the newly Wanted components
-      case sequence mb_evs' of
-        Just evs' -> setEvBind ev (EvTupleMk evs')
-        Nothing   -> return ()
-      
-      return (unionWorkLists wlists)
-    go ev (IrredPred ev_ty)    = canIrredEvidence fl ev ev_ty
-
-canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
-canClassToWorkList fl v cn tys 
-  = do { (xis,cos,ccs) <- flattenMany fl tys  -- cos :: xis ~ tys
-       ; let no_flattening_happened = all isReflCo cos
-             dict_co = mkTyConAppCo (classTyCon cn) cos
-       ; v_new <- if no_flattening_happened  then return v
-                  else if isGivenOrSolved fl then return v
-                         -- The cos are all identities if fl=Given,
-                         -- hence nothing to do
-                  else do { v' <- newDictVar cn xis  -- D xis
-                          ; when (isWanted fl) $ setEvBind v (EvCast v' dict_co)
-                          ; when (isGivenOrSolved fl) $ setEvBind v' (EvCast v (mkSymCo dict_co))
-                                 -- NB: No more setting evidence for derived now 
-                          ; return v' }
-
-       -- Add the superclasses of this one here, See Note [Adding superclasses]. 
-       -- But only if we are not simplifying the LHS of a rule. 
-       ; sctx <- getTcSContext
-       ; sc_cts <- if simplEqsOnly sctx then return emptyWorkList
-                   else newSCWorkFromFlavored v_new fl cn xis
-
-       ; return (sc_cts `unionWorkList` 
-                 workListFromEqs ccs `unionWorkList` 
-                 workListFromNonEq CDictCan { cc_id     = v_new
-                                           , cc_flavor = fl
-                                           , cc_class  = cn 
-                                           , cc_tyargs = xis }) }
+-- Class Canonicalization
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+canClass :: SubGoalDepth -- Depth
+         -> CtFlavor -> EvVar  
+         -> Class -> [Type] -> TcS StopOrContinue
+-- Precondition: EvVar is class evidence 
+-- Note: Does NOT add superclasses, but the /caller/ is responsible for adding them!
+canClass d fl v cls tys
+  = do { -- sctx <- getTcSContext
+       ; (xis, cos) <- flattenMany d fl tys
+       ; let co = mkTyConAppCo (classTyCon cls) cos 
+             xi = mkClassPred cls xis
+
+                  -- No flattening, continue with canonical
+       ; if isReflCo co then 
+             continueWith $ CDictCan { cc_id = v, cc_flavor = fl
+                                     , cc_tyargs = xis, cc_class = cls
+                                     , cc_depth = d }
+                   -- Flattening happened
+         else do { evc <- newEvVar fl xi
+                 ; let v_new = evc_the_evvar evc
+                 ; case fl of
+                     Wanted  {} -> setEvBind v (EvCast v_new co)
+                     Given   {} -> setEvBind v_new (EvCast v (mkSymCo co))
+                     Derived {} -> return ()
+                    -- Continue only if flat constraint is new
+                 ; if isNewEvVar evc then
+                        continueWith $ CDictCan { cc_id = v_new, cc_flavor = fl
+                                                , cc_tyargs = xis, cc_class = cls
+                                                , cc_depth  = d }
+                   else return Stop } }
 \end{code}
 
 Note [Adding superclasses]
@@ -352,130 +378,373 @@ happen.
 
 \begin{code}
 
-newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS WorkList
+newSCWorkFromFlavored :: SubGoalDepth -- Depth
+                      -> EvVar -> CtFlavor -> Class -> [Xi] -> TcS ()
 -- Returns superclasses, see Note [Adding superclasses]
-newSCWorkFromFlavored ev flavor cls xis 
+newSCWorkFromFlavored d ev flavor cls xis 
   | isDerived flavor 
-  = return emptyWorkList  -- Deriveds don't yield more superclasses because we will
-                          -- add them transitively in the case of wanteds. 
+  = return ()  -- Deriveds don't yield more superclasses because we will
+               -- add them transitively in the case of wanteds. 
 
   | Just gk <- isGiven_maybe flavor 
   = case gk of 
       GivenOrig -> do { let sc_theta = immSuperClasses cls xis 
-                      ; sc_vars <- mapM newEvVar sc_theta
-                      ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
-                      ; mkCanonicals flavor sc_vars }
-      GivenSolved -> return emptyWorkList 
+                      ; sc_vars <- mapM (newEvVar flavor) sc_theta
+                      ; sc_cts <- zipWithM (\scv ev_trm -> 
+                                                do { let sc_evvar = evc_the_evvar scv
+                                                   ; setEvBind sc_evvar ev_trm
+                                                   ; return $ 
+                                                     CNonCanonical { cc_id = sc_evvar
+                                                                   , cc_flavor = flavor
+                                                                   , cc_depth = d }}) 
+                                           sc_vars [EvSuperClass ev n | n <- [0..]]
+                        -- Emit now, canonicalize later in a lazier fashion
+                      ; traceTcS "newSCWorkFromFlavored" $
+                                 text "Emitting superclass work:" <+> ppr sc_cts
+                      ; updWorkListTcS $ appendWorkListCt sc_cts }
+      GivenSolved -> return ()
       -- Seems very dangerous to add the superclasses for dictionaries that may be 
       -- partially solved because we may end up with evidence loops.
 
   | isEmptyVarSet (tyVarsOfTypes xis)
-  = return emptyWorkList -- Wanteds with no variables yield no deriveds.
-                         -- See Note [Improvement from Ground Wanteds]
+  = return () -- Wanteds with no variables yield no deriveds.
+              -- See Note [Improvement from Ground Wanteds]
 
   | otherwise -- Wanted case, just add those SC that can lead to improvement. 
   = do { let sc_rec_theta = transSuperClasses cls xis 
              impr_theta   = filter is_improvement_pty sc_rec_theta 
              Wanted wloc  = flavor
-       ; der_ids <- mapM newDerivedId impr_theta
-       ; mkCanonicals (Derived wloc) der_ids }
-
+       ; sc_cts <- mapM (\pty -> do { scv <- newEvVar (Derived wloc) pty
+                                    ; if isNewEvVar scv then 
+                                          return [ CNonCanonical { cc_id = evc_the_evvar scv
+                                                                 , cc_flavor = Derived wloc
+                                                                 , cc_depth = d } ]  
+                                      else return [] }
+                        ) impr_theta
+       ; let sc_cts_flat = concat sc_cts
+       ; traceTcS "newSCWorkFromFlavored" (text "Emitting superclass work:" <+> ppr sc_cts_flat)
+       ; updWorkListTcS $ appendWorkListCt sc_cts_flat }
 
 is_improvement_pty :: PredType -> Bool 
 -- Either it's an equality, or has some functional dependency
-is_improvement_pty ty = go (predTypePredTree ty)
+is_improvement_pty ty = go (classifyPredType ty)
   where
     go (EqPred {})         = True 
-    go (ClassPred cls _ty) = not $ null fundeps
-      where (_,fundeps,_,_,_,_) = classExtraBigSig cls
+    go (ClassPred cls _tys) = not $ null fundeps
+      where (_,fundeps) = classTvsFds cls
     go (IPPred {})         = False
-    go (TuplePred ts)      = any go ts
+    go (TuplePred ts)      = any is_improvement_pty ts
     go (IrredPred {})      = True -- Might have equalities after reduction?
+\end{code}
 
 
 
+\begin{code}
+-- Irreducibles canonicalization
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+canIrred :: SubGoalDepth -- Depth
+         -> CtFlavor -> EvVar -> TcType -> TcS StopOrContinue
+-- Precondition: ty not a tuple and no other evidence form
+canIrred d fl v ty 
+  = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) 
+       ; (xi,co) <- flatten d fl ty -- co :: xi ~ ty
+       ; let no_flattening = isReflCo co
+       ; if no_flattening then
+            continueWith $ CIrredEvCan { cc_id = v, cc_flavor = fl
+                                       , cc_ty = xi, cc_depth  = d }
+         else do
+      {   -- Flattening consults and applies family equations from the
+          -- inerts, so 'xi' may become reducible. So just recursively
+          -- canonicalise the resulting evidence variable
+        evc <- newEvVar fl xi
+      ; let v' = evc_the_evvar evc
+      ; case fl of 
+          Wanted  {} -> setEvBind v (EvCast v' co)
+          Given   {} -> setEvBind v' (EvCast v (mkSymCo co)) 
+          Derived {} -> return ()
+      
+      ; if isNewEvVar evc then 
+            canEvVar v' (classifyPredType (evVarPred v')) d fl
+        else
+            return Stop }
+      }
 
-canIPToWorkList :: CtFlavor -> EvVar -> IPName Name -> TcType -> TcS WorkList
--- See Note [Canonical implicit parameter constraints] to see why we don't 
--- immediately canonicalize (flatten) IP constraints. 
-canIPToWorkList fl v nm ty 
-  = return $ workListFromNonEq (CIPCan { cc_id = v
-                                      , cc_flavor = fl
-                                      , cc_ip_nm = nm
-                                      , cc_ip_ty = ty })
+\end{code}
 
-canIrredEvidence :: CtFlavor -> EvVar -> TcType -> TcS WorkList
-canIrredEvidence fl v ty = do
-    (xi, co, ccs) <- flatten fl ty -- co :: xi ~ ty
-    v' <- newEvVar xi
-    case fl of 
-        Wanted {}         -> setEvBind v  (EvCast v' co)
-        Given {}          -> setEvBind v' (EvCast v (mkSymCo co))
-        Derived {}        -> return () -- Derived ips: we don't set any evidence
-    
-    return (workListFromEqs ccs `unionWorkList`
-            workListFromNonEq (CIrredEvCan { cc_id = v'
-                                           , cc_flavor = fl
-                                           , cc_ty = xi }))
+%************************************************************************
+%*                                                                      *
+%*        Flattening (eliminating all function symbols)                 *
+%*                                                                      *
+%************************************************************************
+
+Note [Flattening]
+~~~~~~~~~~~~~~~~~~~~
+  flatten ty  ==>   (xi, cc)
+    where
+      xi has no type functions
+      cc = Auxiliary given (equality) constraints constraining
+           the fresh type variables in xi.  Evidence for these 
+           is always the identity coercion, because internally the
+           fresh flattening skolem variables are actually identified
+           with the types they have been generated to stand in for.
+
+Note that it is flatten's job to flatten *every type function it sees*.
+flatten is only called on *arguments* to type functions, by canEqGiven.
+
+Recall that in comments we use alpha[flat = ty] to represent a
+flattening skolem variable alpha which has been generated to stand in
+for ty.
+
+----- Example of flattening a constraint: ------
+  flatten (List (F (G Int)))  ==>  (xi, cc)
+    where
+      xi  = List alpha
+      cc  = { G Int ~ beta[flat = G Int],
+              F beta ~ alpha[flat = F beta] }
+Here
+  * alpha and beta are 'flattening skolem variables'.
+  * All the constraints in cc are 'given', and all their coercion terms 
+    are the identity.
+
+NB: Flattening Skolems only occur in canonical constraints, which
+are never zonked, so we don't need to worry about zonking doing
+accidental unflattening.
+
+Note that we prefer to leave type synonyms unexpanded when possible,
+so when the flattener encounters one, it first asks whether its
+transitive expansion contains any type function applications.  If so,
+it expands the synonym and proceeds; if not, it simply returns the
+unexpanded synonym.
+
+TODO: caching the information about whether transitive synonym
+expansions contain any type function applications would speed things
+up a bit; right now we waste a lot of energy traversing the same types
+multiple times.
+
+\begin{code}
+
+-- Flatten a bunch of types all at once.
+flattenMany :: SubGoalDepth -- Depth
+            -> CtFlavor -> [Type] -> TcS ([Xi], [LCoercion])
+-- Coercions :: Xi ~ Type 
+flattenMany d ctxt tys 
+  = do { (xis, cos) <- mapAndUnzipM (flatten d ctxt) tys
+       ; return (xis, cos) }
+
+-- Flatten a type to get rid of type function applications, returning
+-- the new type-function-free type, and a collection of new equality
+-- constraints.  See Note [Flattening] for more detail.
+flatten :: SubGoalDepth -- Depth
+        -> CtFlavor -> TcType -> TcS (Xi, LCoercion)
+-- Postcondition: Coercion :: Xi ~ TcType
+flatten d ctxt ty 
+  | Just ty' <- tcView ty
+  = do { (xi, co) <- flatten d ctxt ty'
+	-- Preserve type synonyms if possible
+       ; if isReflCo co 
+         then return (ty, mkReflCo ty) -- Importantly, not xi!
+         else return (xi, co) 
+       }
+
+flatten _d ctxt v@(TyVarTy _)
+  = do { ieqs <- getInertEqs
+       ; let co = liftInertEqsTy ieqs ctxt v                 -- co :: v ~ xi
+       ; return (pSnd (liftedCoercionKind co), mkSymCo co) } -- return xi ~ v
+
+flatten d ctxt (AppTy ty1 ty2)
+  = do { (xi1,co1) <- flatten d ctxt ty1
+       ; (xi2,co2) <- flatten d ctxt ty2
+       ; return (mkAppTy xi1 xi2, mkAppCo co1 co2) }
+
+flatten d ctxt (FunTy ty1 ty2)
+  = do { (xi1,co1) <- flatten d ctxt ty1
+       ; (xi2,co2) <- flatten d ctxt ty2
+       ; return (mkFunTy xi1 xi2, mkFunCo co1 co2) }
+
+flatten d fl (TyConApp tc tys)
+  -- For a normal type constructor or data family application, we just
+  -- recursively flatten the arguments.
+  | not (isSynFamilyTyCon tc)
+    = do { (xis,cos) <- flattenMany d fl tys
+         ; return (mkTyConApp tc xis, mkTyConAppCo tc cos) }
+
+  -- Otherwise, it's a type function application, and we have to
+  -- flatten it away as well, and generate a new given equality constraint
+  -- between the application and a newly generated flattening skolem variable.
+  | otherwise
+  = ASSERT( tyConArity tc <= length tys )	-- Type functions are saturated
+      do { (xis, cos) <- flattenMany d fl tys
+         ; let (xi_args, xi_rest)  = splitAt (tyConArity tc) xis
+	       	 -- The type function might be *over* saturated
+		 -- in which case the remaining arguments should
+		 -- be dealt with by AppTys
+               fam_ty = mkTyConApp tc xi_args
+         ; (ret_co, rhs_var, ct) <-
+             do { is_cached <- getCachedFlatEq tc xi_args fl Any
+                ; case is_cached of
+                    Just (rhs_var,ret_eq) -> 
+                        do { traceTcS "is_cached!" $ ppr ret_eq
+                           ; return (ret_eq, rhs_var, []) }
+                    Nothing
+                        | isGivenOrSolved fl ->
+                            do { rhs_var <- newFlattenSkolemTy fam_ty
+                               ; eqv <- newGivenEqVar fl fam_ty rhs_var (mkReflCo fam_ty)
+                               ; let ct  = CFunEqCan { cc_id     = eqv
+                                                     , cc_flavor = fl -- Given
+                                                     , cc_fun    = tc 
+                                                     , cc_tyargs = xi_args 
+                                                     , cc_rhs    = rhs_var 
+                                                     , cc_depth  = d }
+                                           -- Update the flat cache: just an optimisation!
+                               ; updateFlatCache eqv fl tc xi_args rhs_var WhileFlattening
+
+                               ; return (mkEqVarLCo eqv, rhs_var, [ct]) }
+                        | otherwise ->
+                    -- Derived or Wanted: make a new /unification/ flatten variable
+                            do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
+                               ; let wanted_flavor = mkWantedFlavor fl
+                               ; evc <- newEqVar wanted_flavor fam_ty rhs_var
+                               ; let eqv = evc_the_evvar evc -- Not going to be cached
+                                     ct = CFunEqCan { cc_id = eqv
+                                                    , cc_flavor = wanted_flavor
+                                                    -- Always Wanted, not Derived
+                                                    , cc_fun = tc
+                                                    , cc_tyargs = xi_args
+                                                    , cc_rhs    = rhs_var 
+                                                    , cc_depth  = d }
+                                          -- Update the flat cache: just an optimisation!
+                               ; updateFlatCache eqv fl tc xi_args rhs_var WhileFlattening
+                               ; return (mkEqVarLCo eqv, rhs_var, [ct]) } }
+
+           -- Emit the flat constraints
+         ; updWorkListTcS $ appendWorkListEqs ct
+
+         ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos
+         ; return ( foldl AppTy rhs_var xi_rest
+                  , foldl AppCo (mkSymCo ret_co `mkTransCo` mkTyConAppCo tc cos_args)
+                                cos_rest) }
+
+
+flatten d ctxt ty@(ForAllTy {})
+-- We allow for-alls when, but only when, no type function
+-- applications inside the forall involve the bound type variables.
+  = do { let (tvs, rho) = splitForAllTys ty
+       ; when (under_families tvs rho) $ flattenForAllErrorTcS ctxt ty
+       ; (rho', co) <- flatten d ctxt rho
+       ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs) }
+
+  where under_families tvs rho 
+            = go (mkVarSet tvs) rho 
+            where go _bound (TyVarTy _tv) = False
+                  go bound (TyConApp tc tys)
+                      | isSynFamilyTyCon tc
+                      , (args,rest) <- splitAt (tyConArity tc) tys
+                      = (tyVarsOfTypes args `intersectsVarSet` bound) || any (go bound) rest
+                      | otherwise = any (go bound) tys
+                  go bound (FunTy arg res)  = go bound arg || go bound res
+                  go bound (AppTy fun arg)  = go bound fun || go bound arg
+                  go bound (ForAllTy tv ty) = go (bound `extendVarSet` tv) ty
+
+
+getCachedFlatEq :: TyCon -> [Xi] -> CtFlavor 
+                -> FlatEqOrigin
+                -> TcS (Maybe (Xi,Coercion))
+-- Returns a coercion between (TyConApp tc xi_args ~ xi) if such an inert item exists
+-- But also applies the substitution to the item via calling flatten recursively
+getCachedFlatEq tc xi_args fl feq_origin
+  = do { let pty = mkTyConApp tc xi_args
+       ; traceTcS "getCachedFlatEq" $ ppr (mkTyConApp tc xi_args)
+       ; flat_cache <- getTcSEvVarFlatCache
+       ; inerts <- getTcSInerts
+       ; case lookupFunEq pty fl (inert_funeqs inerts) of
+           Nothing -> lookup_in_flat_cache pty flat_cache
+           res     -> return res }
+  where lookup_in_flat_cache pty flat_cache 
+          = case lookupTM pty flat_cache of
+              Just (co',(xi',fl',when_generated)) -- ev' :: (TyConApp tc xi_args) ~ xi'
+               | fl' `canRewrite` fl
+               , feq_origin `origin_matches` when_generated
+               -> do { traceTcS "getCachedFlatEq" $ text "success!"
+                     ; (xi'',co) <- flatten 0 fl' xi' -- co :: xi'' ~ xi'
+                     ; return $ Just (xi'', co' `mkTransCo` (mkSymCo co)) }
+              _ -> do { traceTcS "getCachedFlatEq" $ text "failure!" <+> pprEvVarCache flat_cache
+                      ; return Nothing }
+
+
+\end{code}
 
------------------
-canEqToWorkList :: CtFlavor -> EvVar -> Type -> Type -> TcS WorkList
-canEqToWorkList fl eqv ty1 ty2 = do { cts <- canEq fl eqv ty1 ty2 
-                                   ; return $ workListFromEqs cts }
 
-canEq :: CtFlavor -> EqVar -> Type -> Type -> TcS CanonicalCts 
-canEq fl eqv ty1 ty2
+\begin{code}
+
+-----------------
+addToWork :: TcS StopOrContinue -> TcS ()
+addToWork tcs_action = tcs_action >>= stop_or_emit
+  where stop_or_emit Stop              = return ()
+        stop_or_emit (ContinueWith ct) = updWorkListTcS $ 
+                                         extendWorkListCt ct
+
+canEqEvVarsCreated :: SubGoalDepth -> CtFlavor 
+                   -> [EvVarCreated] -> [Type] -> [Type]
+                   -> TcS StopOrContinue
+canEqEvVarsCreated _d _fl [] _ _    = return Stop
+canEqEvVarsCreated d fl (evc:evcs) (ty1:tys1) (ty2:tys2) 
+  | isNewEvVar evc 
+  = let do_one evc0 sy1 sy2
+          | isNewEvVar evc0 
+          = canEq_ d fl (evc_the_evvar evc0) sy1 sy2
+          | otherwise = return ()
+    in do { _unused <- zipWith3M do_one evcs tys1 tys2 
+          ; canEq d fl (evc_the_evvar evc) ty1 ty2 }
+  | otherwise 
+  = canEqEvVarsCreated d fl evcs tys1 tys2
+canEqEvVarsCreated _ _ _ _ _ = return Stop
+
+
+canEq_ :: SubGoalDepth 
+       -> CtFlavor -> EqVar -> Type -> Type -> TcS ()
+canEq_ d fl eqv ty1 ty2 = addToWork (canEq d fl eqv ty1 ty2)
+
+canEq :: SubGoalDepth 
+      -> CtFlavor -> EqVar -> Type -> Type -> TcS StopOrContinue
+canEq _d fl eqv ty1 ty2
   | eqType ty1 ty2	-- Dealing with equality here avoids
     	     	 	-- later spurious occurs checks for a~a
   = do { when (isWanted fl) (setEqBind eqv (mkReflCo ty1))
-       ; return emptyCCan }
+       ; return Stop }
 
--- If one side is a variable, orient and flatten, 
+-- Split up an equality between function types into two equalities.
+canEq d fl eqv (FunTy s1 t1) (FunTy s2 t2)
+  = do { argeqv <- newEqVar fl s1 s2
+       ; reseqv <- newEqVar fl t1 t2
+       ; let argeqv_v = evc_the_evvar argeqv
+             reseqv_v = evc_the_evvar reseqv
+       ; case fl of
+           Wanted {} ->
+               setEqBind eqv (mkFunCo (mkEqVarLCo argeqv_v) (mkEqVarLCo reseqv_v))
+           Given {} ->
+               do { setEqBind argeqv_v (mkNthCo 0 (mkEqVarLCo eqv))
+                  ; setEqBind reseqv_v (mkNthCo 1 (mkEqVarLCo eqv)) }
+           Derived {} ->
+               return ()
+
+       ; canEqEvVarsCreated d fl [reseqv,argeqv] [t1,s1] [t2,s2] }
+
+-- If one side is a variable, orient and flatten,
 -- WITHOUT expanding type synonyms, so that we tend to 
 -- substitute a ~ Age rather than a ~ Int when @type Age = Int@
-canEq fl eqv ty1@(TyVarTy {}) ty2 
-  = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl eqv (classify ty1) (classify ty2) }
-canEq fl eqv ty1 ty2@(TyVarTy {}) 
-  = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl eqv (classify ty1) (classify ty2) }
-      -- NB: don't use VarCls directly because tv1 or tv2 may be scolems!
+canEq d fl eqv ty1@(TyVarTy {}) ty2 
+  = canEqLeaf d fl eqv ty1 ty2
+canEq d fl eqv ty1 ty2@(TyVarTy {})
+  = canEqLeaf d fl eqv ty1 ty2
 
--- Split up an equality between function types into two equalities.
-canEq fl eqv (FunTy s1 t1) (FunTy s2 t2)
-  = do { (argeqv, reseqv) <- 
-             if isWanted fl then 
-                 do { argeqv <- newEqVar s1 s2 
-                    ; reseqv <- newEqVar t1 t2 
-                    ; setEqBind eqv
-                      (mkFunCo (mkEqVarLCo argeqv) (mkEqVarLCo reseqv))
-                    ; return (argeqv,reseqv) } 
-             else if isGivenOrSolved fl then 
-                      do { argeqv <- newEqVar s1 s2
-                         ; setEqBind argeqv (mkNthCo 0 (mkEqVarLCo eqv))
-                         ; reseqv <- newEqVar t1 t2
-                         ; setEqBind reseqv (mkNthCo 1 (mkEqVarLCo eqv))
-                         ; return (argeqv,reseqv) } 
-
-             else -- Derived 
-                 do { argeqv <- newDerivedId (mkEqPred (s1, s2))
-                    ; reseqv <- newDerivedId (mkEqPred (t1, t2))
-                    ; return (argeqv, reseqv) }
-
-       ; cc1 <- canEq fl argeqv s1 s2 -- inherit original kinds and locations
-       ; cc2 <- canEq fl reseqv t1 t2
-       ; return (cc1 `andCCan` cc2) }
-
-canEq fl eqv (TyConApp fn tys) ty2 
+canEq d fl eqv ty1@(TyConApp fn tys) ty2 
   | isSynFamilyTyCon fn, length tys == tyConArity fn
-  = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl eqv (FunCls fn tys) (classify ty2) }
-canEq fl eqv ty1 (TyConApp fn tys)
+  = canEqLeaf d fl eqv ty1 ty2
+canEq d fl eqv ty1 ty2@(TyConApp fn tys)
   | isSynFamilyTyCon fn, length tys == tyConArity fn
-  = do { untch <- getUntouchables 
-       ; canEqLeaf untch fl eqv (classify ty1) (FunCls fn tys) }
+  = canEqLeaf d fl eqv ty1 ty2
 
-canEq fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
   | isDecomposableTyCon tc1 && isDecomposableTyCon tc2
   , tc1 == tc2
   , length tys1 == length tys2
@@ -483,70 +752,63 @@ canEq fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
     do { let (kis1,  tys1') = span isKind tys1
              (_kis2, tys2') = span isKind tys2
        ; let kicos = map mkReflCo kis1
-       ; argeqvs
-             <- if isWanted fl then
-                    do { argeqvs <- zipWithM newEqVar tys1' tys2'
-                       ; setEqBind eqv
-                         (mkTyConAppCo tc1 (kicos ++ (map mkEqVarLCo argeqvs)))
-                       ; return argeqvs }
-                else if isGivenOrSolved fl then
-                    let go_one ty1 ty2 n = do
-                          argeqv <- newEqVar ty1 ty2
-                          setEqBind argeqv (mkNthCo n (mkEqVarLCo eqv))
-                          return argeqv
-                    in zipWith3M go_one tys1' tys2' [(length kicos)..]
-
-                else -- Derived 
-                    zipWithM (\t1 t2 -> newDerivedId (mkEqPred (t1, t2))) tys1' tys2'
-
-       ; andCCans <$> zipWith3M (canEq fl) argeqvs tys1' tys2' }
+
+       ; argeqvs <- zipWithM (newEqVar fl) tys1' tys2'
+       ; case fl of 
+           Wanted {} -> 
+             setEqBind eqv $ 
+             mkTyConAppCo tc1 (kicos ++ map (mkEqVarLCo . evc_the_evvar) argeqvs)
+           Given {} ->
+             let do_one argeqv n = setEqBind (evc_the_evvar argeqv) 
+                                             (mkNthCo n (mkEqVarLCo eqv))
+             in zipWithM_ do_one argeqvs [(length kicos)..]
+           Derived {} -> return ()
+
+       ; canEqEvVarsCreated d fl argeqvs tys1' tys2' }
 
 -- See Note [Equality between type applications]
 --     Note [Care with type applications] in TcUnify
-canEq fl eqv ty1 ty2
+canEq d fl eqv ty1 ty2
   | Nothing <- tcView ty1  -- Naked applications ONLY
   , Nothing <- tcView ty2  -- See Note [Naked given applications]
   , Just (s1,t1) <- tcSplitAppTy_maybe ty1
   , Just (s2,t2) <- tcSplitAppTy_maybe ty2
-    = ASSERT( not (isKind t1) && not (isKind t2) )
-      if isWanted fl 
-      then do { eqv1 <- newEqVar s1 s2 
-              ; eqv2 <- newEqVar t1 t2 
-              ; setEqBind eqv
-                (mkAppCo (mkEqVarLCo eqv1) (mkEqVarLCo eqv2))
-              ; cc1 <- canEq fl eqv1 s1 s2 
-              ; cc2 <- canEq fl eqv2 t1 t2 
-              ; return (cc1 `andCCan` cc2) } 
-
-      else if isDerived fl 
-      then do { eqv1 <- newDerivedId (mkEqPred (s1, s2))
-              ; eqv2 <- newDerivedId (mkEqPred (t1, t2))
-              ; cc1 <- canEq fl eqv1 s1 s2 
-              ; cc2 <- canEq fl eqv2 t1 t2 
-              ; return (cc1 `andCCan` cc2) } 
-      
-      else do { traceTcS "canEq/(app case)" $
+  = ASSERT( not (isKind t1) && not (isKind t2) )
+    if isGivenOrSolved fl then 
+        do { traceTcS "canEq/(app case)" $
                 text "Ommitting decomposition of given equality between: " 
-                          <+> ppr ty1 <+> text "and" <+> ppr ty2
-              ; return emptyCCan    -- We cannot decompose given applications
-      	   	  	            -- because we no longer have 'left' and 'right'
-              }
+                    <+> ppr ty1 <+> text "and" <+> ppr ty2
+                   -- We cannot decompose given applications
+                   -- because we no longer have 'left' and 'right'
+           ; return Stop }
+    else
+        do { evc1 <- newEqVar fl s1 s2
+           ; evc2 <- newEqVar fl t1 t2
+           ; let eqv1 = evc_the_evvar evc1
+                 eqv2 = evc_the_evvar evc2
+ 
+           ; when (isWanted fl) $
+                  setEqBind eqv (mkAppCo (mkEqVarLCo eqv1) (mkEqVarLCo eqv2))
+           
+           ; canEqEvVarsCreated d fl [evc1,evc2] [s1,t1] [s2,t2] }
+
 
-canEq fl eqv s1@(ForAllTy {}) s2@(ForAllTy {})
+canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {})
  | tcIsForAllTy s1, tcIsForAllTy s2, 
    Wanted {} <- fl 
- = canEqFailure fl eqv
+ = canEqFailure d fl eqv
  | otherwise
  = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2)
-      ; return emptyCCan }
+      ; return Stop }
 
 -- Finally expand any type synonym applications.
-canEq fl eqv ty1 ty2 | Just ty1' <- tcView ty1 = canEq fl eqv ty1' ty2
-canEq fl eqv ty1 ty2 | Just ty2' <- tcView ty2 = canEq fl eqv ty1 ty2'
-canEq fl eqv _ _                               = canEqFailure fl eqv
+canEq d fl eqv ty1 ty2 | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2
+canEq d fl eqv ty1 ty2 | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2'
+canEq d fl eqv _ _                               = canEqFailure d fl eqv
 
-canEqFailure :: CtFlavor -> EvVar -> TcS CanonicalCts
-canEqFailure fl eqv = return (singleCCan (mkFrozenError fl eqv))
+canEqFailure :: SubGoalDepth 
+             -> CtFlavor -> EvVar -> TcS StopOrContinue
+canEqFailure d fl eqv = do { emitFrozenError fl eqv d; return Stop }
 \end{code}
 
 Note [Naked given applications]
@@ -681,11 +943,13 @@ data TypeClassifier
   | FunCls TyCon [Type] -- ^ Type function, exactly saturated
   | OtherCls TcType     -- ^ Neither of the above
 
+{- Useless these days! 
 unClassify :: TypeClassifier -> TcType
 unClassify (VarCls tv)      = TyVarTy tv
 unClassify (FskCls tv) = TyVarTy tv 
 unClassify (FunCls fn tys)  = TyConApp fn tys
 unClassify (OtherCls ty)    = ty
+-} 
 
 classify :: TcType -> TypeClassifier
 
@@ -739,131 +1003,265 @@ reOrient _fl (FskCls {}) (FunCls {})     = True
 reOrient _fl (FskCls {}) (OtherCls {})   = False 
 
 ------------------
-canEqLeaf :: TcsUntouchables 
+
+canEqLeaf :: SubGoalDepth -- Depth
           -> CtFlavor -> EqVar 
-          -> TypeClassifier -> TypeClassifier -> TcS CanonicalCts 
+          -> Type -> Type 
+          -> TcS StopOrContinue
 -- Canonicalizing "leaf" equality constraints which cannot be
 -- decomposed further (ie one of the types is a variable or
 -- saturated type function application).  
 
-  -- Preconditions: 
-  --    * one of the two arguments is not OtherCls
-  --    * the two types are not equal (looking through synonyms)
-canEqLeaf _untch fl eqv cls1 cls2 
+-- Preconditions: 
+--    * one of the two arguments is variable or family applications
+--    * the two types are not equal (looking through synonyms)
+canEqLeaf d fl eqv s1 s2 
   | cls1 `re_orient` cls2
-  = do { eqv' <- if isWanted fl 
-                 then do { eqv' <- newEqVar s2 s1
-                         ; setEqBind eqv (mkSymCo (mkEqVarLCo eqv'))
-                         ; return eqv' } 
-                 else if isGivenOrSolved fl then
-                      do { eqv' <- newEqVar s2 s1
-                         ; setEqBind eqv' (mkSymCo (mkEqVarLCo eqv))
-                         ; return eqv' }
-                          
-                 else -- Derived
-                     newDerivedId (mkEqPred (s2, s1))
-       ; canEqLeafOriented fl eqv' cls2 s1 }
-
+  = do { traceTcS "canEqLeaf (reorienting)" $ ppr (evVarPred eqv)
+       ; delCachedEvVar eqv
+       ; evc <- newEqVar fl s2 s1
+       ; let eqv' = evc_the_evvar evc
+       ; case fl of 
+           Wanted {}  -> setEqBind eqv (mkSymCo (mkEqVarLCo eqv'))
+           Given {}   -> setEqBind eqv' (mkSymCo (mkEqVarLCo eqv))
+           Derived {} -> return ()
+       ; if isNewEvVar evc then 
+             do { canEqLeafOriented d fl eqv' s2 s1 }
+         else return Stop 
+       }
   | otherwise
-  = do { traceTcS "canEqLeaf" (ppr (unClassify cls1) $$ ppr (unClassify cls2))
-       ; canEqLeafOriented fl eqv cls1 s2 }
+  = do { traceTcS "canEqLeaf" $ ppr (mkEqPred (s1,s2))
+       ; canEqLeafOriented d fl eqv s1 s2 }
   where
     re_orient = reOrient fl 
-    s1 = unClassify cls1  
-    s2 = unClassify cls2  
-
-------------------
-canEqLeafOriented :: CtFlavor -> EqVar 
-                  -> TypeClassifier -> TcType -> TcS CanonicalCts 
--- First argument is not OtherCls
-canEqLeafOriented fl eqv cls1@(FunCls fn tys1) s2         -- cv : F tys1
-  = ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) )
-    do { are_compat <- compatKindTcS k1 k2  -- make sure that the kind are compatible
-       ; can_unify <- if not are_compat 
-                      then unifyKindTcS (unClassify cls1) s2 k1 k2
-                      else return False
-         -- If the kinds cannot be unified or are not compatible, don't fail
-         -- right away; instead, emit a frozen error
-       ; if (not are_compat && not can_unify) then canEqFailure fl eqv else
-    do {
-         (xis1,cos1,ccs1) <- flattenMany fl tys1 -- Flatten type function arguments
-                                                 -- cos1 :: xis1 ~ tys1
-       ; (xi2, co2, ccs2) <- flatten fl s2       -- Flatten entire RHS
-                                                 -- co2  :: xi2 ~ s2
-       ; let ccs = ccs1 `andCCan` ccs2
-             no_flattening_happened = all isReflCo (co2:cos1)
-       ; eqv_new <- if no_flattening_happened  then return eqv
-                    else if isGivenOrSolved fl then return eqv
-                    else if isWanted fl then 
-                          do { eqv' <- newEqVar (unClassify (FunCls fn xis1)) xi2
-
-                             ; let -- cv' : F xis ~ xi2
-                                   cv' = mkEqVarLCo eqv'
-                                   -- fun_co :: F xis1 ~ F tys1
-                                   fun_co = mkTyConAppCo fn cos1
-                                   -- want_co :: F tys1 ~ s2
-                                   want_co = mkSymCo fun_co
-                                                `mkTransCo` cv'
-                                                `mkTransCo` co2
-                             ; setEqBind eqv want_co
-                             ; return eqv' }
-                    else -- Derived 
-                        newDerivedId (mkEqPred (unClassify (FunCls fn xis1), xi2))
-
-       ; let final_cc = CFunEqCan { cc_id     = eqv_new
-                                  , cc_flavor = fl
-                                  , cc_fun    = fn
-                                  , cc_tyargs = xis1 
-                                  , cc_rhs    = xi2 }
-       ; return $ ccs `extendCCans` final_cc } }
-  where
-    k1 = typeKind (unClassify cls1)
-    k2 = typeKind s2
-
-
--- Otherwise, we have a variable on the left, so call canEqLeafTyVarLeft
-canEqLeafOriented fl eqv (FskCls tv) s2 
-  = canEqLeafTyVarLeft fl eqv tv s2 
-canEqLeafOriented fl eqv (VarCls tv) s2 
-  = canEqLeafTyVarLeft fl eqv tv s2 
-canEqLeafOriented _ eqv (OtherCls ty1) ty2 
-  = pprPanic "canEqLeaf" (ppr eqv $$ ppr ty1 $$ ppr ty2)
-
-canEqLeafTyVarLeft :: CtFlavor -> EqVar -> TcTyVar -> TcType -> TcS CanonicalCts
--- Establish invariants of CTyEqCans 
-canEqLeafTyVarLeft fl eqv tv s2       -- cv : tv ~ s2
+    cls1 = classify s1
+    cls2 = classify s2
+
+canEqLeafOriented :: SubGoalDepth -- Depth
+                  -> CtFlavor -> EqVar 
+                  -> TcType -> TcType -> TcS StopOrContinue
+-- By now s1 will either be a variable or a type family application
+canEqLeafOriented d fl eqv s1 s2
+  | let k1 = typeKind s1
+  , let k2 = typeKind s2
+  -- Establish kind invariants for CFunEqCan and CTyEqCan
   = do { are_compat <- compatKindTcS k1 k2
        ; can_unify <- if not are_compat
-                      then unifyKindTcS (mkTyVarTy tv) s2 k1 k2
+                      then unifyKindTcS s1 s2 k1 k2
                       else return False
          -- If the kinds cannot be unified or are not compatible, don't fail
          -- right away; instead, emit a frozen error
-       ; if (not are_compat && not can_unify) then canEqFailure fl eqv else
-    do {
-         (xi2, co, ccs2) <- flatten fl s2  -- Flatten RHS   co : xi2 ~ s2
-       ; mxi2' <- canOccursCheck fl tv xi2 -- Do an occurs check, and return a possibly
-                                           -- unfolded version of the RHS, if we had to 
-                                           -- unfold any type synonyms to get rid of tv.
-       ; case mxi2' of {
-           Nothing   -> canEqFailure fl eqv ;
-           Just xi2' ->
-    do { let no_flattening_happened = isReflCo co
-       ; eqv_new <- if no_flattening_happened  then return eqv
-                    else if isGivenOrSolved fl then return eqv
-                    else if isWanted fl then 
-                          do { eqv' <- newEqVar (mkTyVarTy tv) xi2'  -- cv' : tv ~ xi2
-                             ; setEqBind eqv $ mkTransCo (mkEqVarLCo eqv') co
-                             ; return eqv' }
-                    else -- Derived
-                        newDerivedId (mkEqPred (mkTyVarTy tv, xi2'))
-
-       ; return $ ccs2 `extendCCans` CTyEqCan { cc_id     = eqv_new
-                                              , cc_flavor = fl
-                                              , cc_tyvar  = tv
-                                              , cc_rhs    = xi2' } } } } }
-  where
-    k1 = tyVarKind tv
-    k2 = typeKind s2
+       ; if (not are_compat && not can_unify) then
+             canEqFailure d fl eqv
+         else can_eq_kinds_ok d fl eqv s1 s2 }
+
+  where can_eq_kinds_ok d fl eqv s1 s2
+          | Just (fn,tys1) <- splitTyConApp_maybe s1
+          = canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2
+          | Just tv <- getTyVar_maybe s1
+          = canEqLeafTyVarLeftRec d fl eqv tv s2
+          | otherwise
+          = pprPanic "canEqLeafOriented" $
+            text "Non-variable or non-family equality LHS" <+> ppr eqv <+> 
+                                                       dcolon <+> ppr (evVarPred eqv)
+canEqLeafFunEqLeftRec :: SubGoalDepth
+                      -> CtFlavor 
+                      -> EqVar 
+                      -> (TyCon,[TcType]) -> TcType -> TcS StopOrContinue
+canEqLeafFunEqLeftRec d fl eqv (fn,tys1) ty2  -- eqv :: F tys1 ~ ty2
+  = do { traceTcS "canEqLeafFunEqLeftRec" $ ppr (evVarPred eqv)
+       ; (xis1,cos1) <- flattenMany d fl tys1 -- Flatten type function arguments
+                                              -- cos1 :: xis1 ~ tys1
+
+       ; let no_flattening = all isReflCo cos1
+
+       ; inerts <- getTcSInerts
+       ; let fam_eqs   = inert_funeqs inerts
+
+       ; let is_cached = lookupFunEq (mkTyConApp fn xis1) fl fam_eqs
+
+       ; if no_flattening && isNothing is_cached then 
+             canEqLeafFunEqLeft d fl eqv (fn,xis1) ty2
+         else do
+       { let (final_co, final_ty)
+                 | no_flattening        -- Just in inerts
+                 , Just (rhs_ty, ret_eq) <- is_cached
+                 = (mkSymCo ret_eq, rhs_ty)
+                 | Nothing <- is_cached -- Just flattening
+                 = (mkTyConAppCo fn cos1, mkTyConApp fn xis1)
+                 | Just (rhs_ty, ret_eq) <- is_cached  -- Both
+                 = (mkSymCo ret_eq `mkTransCo` mkTyConAppCo fn cos1, rhs_ty)
+                 | otherwise = panic "No flattening and not cached!"
+       ; delCachedEvVar eqv
+       ; evc <- newEqVar fl final_ty ty2
+       ; let new_eqv = evc_the_evvar evc
+       ; case fl of
+           Wanted {}  -> setEqBind eqv $ 
+                         mkSymCo final_co `mkTransCo` (mkEqVarLCo new_eqv)
+           Given {}   -> setEqBind new_eqv $ final_co `mkTransCo` (mkEqVarLCo eqv)
+           Derived {} -> return ()
+       ; if isNewEvVar evc then
+             if isNothing is_cached then
+                 canEqLeafFunEqLeft d fl new_eqv (fn,xis1) ty2
+             else
+                 canEq (d+1) fl new_eqv final_ty ty2
+         else return Stop
+       }
+       }
+
+lookupFunEq :: PredType -> CtFlavor -> TypeMap Ct -> Maybe (TcType,Coercion)
+lookupFunEq pty fl fam_eqs = lookup_funeq pty fam_eqs
+  where lookup_funeq pty fam_eqs
+          | Just ct <- lookupTM pty fam_eqs
+          , cc_flavor ct `canRewrite` fl 
+          = Just (cc_rhs ct, mkEqVarLCo (cc_id ct))
+          | otherwise 
+          = Nothing
+
+{- Original, not using inert family equations: 
+       ; if no_flattening then
+             canEqLeafFunEqLeft d fl eqv (fn,xis1) ty2
+         else do  -- There was flattening
+       { let (final_co, final_ty) = (mkTyConAppCo fn cos1, mkTyConApp fn xis1)
+       ; delCachedEvVar eqv
+       ; evc <- newEqVar fl final_ty ty2
+       ; let new_eqv = evc_the_evvar evc
+       ; case fl of
+           Wanted {}  -> setEqBind eqv $ mkSymCo final_co `mkTransCo` (mkEqVarLCo new_eqv)
+           Given {}   -> setEqBind new_eqv $ final_co `mkTransCo` (mkEqVarLCo eqv)
+           Derived {} -> return ()
+       ; if isNewEvVar evc then
+             canEqLeafFunEqLeft d fl new_eqv (fn,xis1) ty2
+         else return Stop 
+       }
+       }
+-}
+
+
+canEqLeafFunEqLeft :: SubGoalDepth -- Depth
+                   -> CtFlavor -> EqVar -> (TyCon,[Xi]) 
+                   -> TcType -> TcS StopOrContinue
+-- Precondition: No more flattening is needed for the LHS
+canEqLeafFunEqLeft d fl eqv (fn,xis1) s2
+ = do { traceTcS "canEqLeafFunEqLeft" $ ppr (evVarPred eqv)
+      ; (xi2,co2) <- flatten d fl s2 -- co2 :: xi2 ~ s2
+      ; let no_flattening_happened = isReflCo co2
+      ; if no_flattening_happened then 
+            continueWith $ CFunEqCan { cc_id     = eqv
+                                     , cc_flavor = fl
+                                     , cc_fun    = fn
+                                     , cc_tyargs = xis1 
+                                     , cc_rhs    = xi2 
+                                     , cc_depth  = d }
+        else do { delCachedEvVar eqv
+                ; evc <- newEqVar fl (mkTyConApp fn xis1) xi2
+                ; let new_eqv = evc_the_evvar evc -- F xis1 ~ xi2 
+                      new_cv  = mkEqVarLCo new_eqv
+                      cv      = mkEqVarLCo eqv    -- F xis1 ~ s2
+                ; case fl of
+                    Wanted {} -> setEqBind eqv $ new_cv `mkTransCo` co2
+                    Given {}  -> setEqBind new_eqv $ cv `mkTransCo` mkSymCo co2
+                    Derived {} -> return ()
+                ; if isNewEvVar evc then 
+                      do { continueWith $
+                           CFunEqCan { cc_id = new_eqv
+                                     , cc_flavor = fl
+                                     , cc_fun    = fn
+                                     , cc_tyargs = xis1 
+                                     , cc_rhs    = xi2 
+                                     , cc_depth  = d } }
+                  else return Stop }  }
+
+
+canEqLeafTyVarLeftRec :: SubGoalDepth
+                      -> CtFlavor -> EqVar
+                      -> TcTyVar -> TcType -> TcS StopOrContinue
+canEqLeafTyVarLeftRec d fl eqv tv s2              -- eqv :: tv ~ s2
+  = do {  traceTcS "canEqLeafTyVarLeftRec" $ ppr (evVarPred eqv)
+       ; (xi1,co1) <- flatten d fl (mkTyVarTy tv) -- co1 :: xi1 ~ tv
+       ; if isReflCo co1 then
+             canEqLeafTyVarLeft d fl eqv tv s2
+         else do { delCachedEvVar eqv
+                 ; evc <- newEqVar fl xi1 s2  -- new_ev :: xi1 ~ s2
+                 ; let new_ev = evc_the_evvar evc
+                 ; case fl of 
+                    Wanted  {} -> setEqBind eqv $ 
+                                  mkSymCo co1 `mkTransCo` mkEqVarLCo new_ev
+                    Given   {} -> setEqBind new_ev $ 
+                                  co1 `mkTransCo` mkEqVarLCo eqv
+                    Derived {} -> return ()
+                ; if isNewEvVar evc then
+                      do { canEq d fl new_ev xi1 s2 }
+                  else return Stop
+                 }
+       }
+
+canEqLeafTyVarLeft :: SubGoalDepth -- Depth
+                   -> CtFlavor -> EqVar
+                   -> TcTyVar -> TcType -> TcS StopOrContinue
+-- Precondition LHS is fully rewritten from inerts (but not RHS)
+canEqLeafTyVarLeft d fl eqv tv s2       -- eqv : tv ~ s2
+  = do { traceTcS "canEqLeafTyVarLeft" (ppr (evVarPred eqv))
+       ; (xi2, co) <- flatten d fl s2   -- Flatten RHS   co : xi2 ~ s2
+       ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv  =" <+> ppr tv
+                                                     , text "s2  =" <+> ppr s2
+                                                     , text "xi2 =" <+> ppr xi2]))
+
+                      -- Flattening the RHS may reveal an identity coercion, which should
+                      -- not be reported as occurs check error! 
+       ; let is_same_tv
+               | Just tv' <- getTyVar_maybe xi2, tv' == tv
+               = True
+               | otherwise = False
+       ; if is_same_tv then
+             do { delCachedEvVar eqv
+                ; when (isWanted fl) $ setEqBind eqv co 
+                ; return Stop }
+         else
+    do { -- Do an occurs check, and return a possibly
+         -- unfolded version of the RHS, if we had to 
+         -- unfold any type synonyms to get rid of tv.
+         occ_check_result <- canOccursCheck fl tv xi2
+
+       ; let xi2'
+              | Just xi2_unfolded <- occ_check_result
+              = xi2_unfolded
+              | otherwise = xi2
+
+       ; let no_flattening_happened = isReflCo co
+
+       ; if no_flattening_happened then
+             if isNothing occ_check_result then 
+                 canEqFailure d fl eqv 
+             else 
+                 continueWith $ CTyEqCan { cc_id     = eqv
+                                         , cc_flavor = fl
+                                         , cc_tyvar  = tv
+                                         , cc_rhs    = xi2'
+                                         , cc_depth  = d }
+         else -- Flattening happened, in any case we have to create new variable 
+              -- even if we report an occurs check error
+             do { delCachedEvVar eqv
+                ; evc <- newEqVar fl (mkTyVarTy tv) xi2' 
+                ; let eqv' = evc_the_evvar evc -- eqv' : tv ~ xi2'
+                      cv   = mkEqVarLCo eqv    -- cv : tv ~ s2
+                      cv'  = mkEqVarLCo eqv'   -- cv': tv ~ xi2'
+                 ; case fl of 
+                     Wanted {}  -> setEqBind eqv (cv' `mkTransCo` co)         -- tv ~ xi2' ~ s2
+                     Given {}   -> setEqBind eqv' (cv `mkTransCo` mkSymCo co) -- tv ~ s2 ~ xi2'
+                     Derived {} -> return ()
+
+                 ; if isNewEvVar evc then 
+                       if isNothing occ_check_result then 
+                           canEqFailure d fl eqv'
+                       else continueWith CTyEqCan { cc_id     = eqv'
+                                                  , cc_flavor = fl
+                                                  , cc_tyvar  = tv
+                                                  , cc_rhs    = xi2' 
+                                                  , cc_depth  = d }
+                   else 
+                       return Stop } } }
+
 
 -- See Note [Type synonyms and canonicalization].
 -- Check whether the given variable occurs in the given type.  We may
@@ -898,7 +1296,7 @@ even though we could also expand F to get rid of b.
 
 \begin{code}
 expandAway :: TcTyVar -> Xi -> Maybe Xi
-expandAway tv t@(TyVarTy tv') 
+expandAway tv t@(TyVarTy tv')
   | tv == tv' = Nothing
   | otherwise = Just t
 expandAway tv xi
@@ -1041,7 +1439,7 @@ rewriteWithFunDeps :: [Equation]
                                            -- Because our intention could be to make 
                                            -- it derived at the end of the day
 -- NB: The flavor of the returned EvVars will be decided by the caller
--- Post: returns no trivial equalities (identities)
+-- Post: returns no trivial equalities (identities) and all EvVars returned are fresh
 rewriteWithFunDeps eqn_pred_locs xis wloc
  = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs
       ; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))]
@@ -1063,9 +1461,14 @@ instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
        = let sty1 = Type.substTy subst ty1 
              sty2 = Type.substTy subst ty2 
          in if eqType sty1 sty2 then return ievs -- Return no trivial equalities
-            else do { eqv <- newEqVar sty1 sty2
+            else do { eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds
                     ; let wl' = push_ctx wl 
-                    ; return $ (i,(eqv,wl')):ievs }
+                    ; if isNewEvVar eqv then 
+                          return $ (i,(evc_the_evvar eqv,wl')):ievs 
+                      else -- We are eventually going to emit FD work back in the work list so 
+                           -- it is important that we only return the /freshly created/ and not 
+                           -- some existing equality!
+                          return ievs }
 
     push_ctx :: WantedLoc -> WantedLoc 
     push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
@@ -1099,18 +1502,22 @@ rewriteDictParams param_eqs tys
       | otherwise 
       = panic "rewriteDictParams: non equality fundep!?"
 
-mkCanonicalFDAsWanted :: [(EvVar,WantedLoc)] -> TcS WorkList
-mkCanonicalFDAsWanted evlocs
-  = do { ws <- mapM can_as_wanted evlocs
-       ; return (unionWorkLists ws) }
-  where can_as_wanted (ev,loc) = mkCanonicalFEV (EvVarX ev (Wanted loc))
-
-
-mkCanonicalFDAsDerived :: [(EvVar,WantedLoc)] -> TcS WorkList
-mkCanonicalFDAsDerived evlocs
-  = do { ws <- mapM can_as_derived evlocs
-       ; return (unionWorkLists ws) }
-  where can_as_derived (ev,loc) = mkCanonicalFEV (EvVarX ev (Derived loc)) 
-
+        
+emitFDWork :: Bool
+           -> [(EvVar,WantedLoc)] 
+           -> SubGoalDepth -> TcS () 
+emitFDWork as_wanted evlocs d 
+  = updWorkListTcS $ appendWorkListEqs fd_cts
+  where fd_cts = map mk_fd_ct evlocs 
+        mk_fl wl = if as_wanted then (Wanted wl) else (Derived wl)
+        mk_fd_ct (v,wl) = CNonCanonical { cc_id = v
+                                        , cc_flavor = mk_fl wl 
+                                        , cc_depth = d }
+
+emitFDWorkAsDerived, emitFDWorkAsWanted :: [(EvVar,WantedLoc)] 
+                                        -> SubGoalDepth 
+                                        -> TcS () 
+emitFDWorkAsDerived = emitFDWork False
+emitFDWorkAsWanted  = emitFDWork True 
 
 \end{code}
\ No newline at end of file
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index b8acec65ba..893cd7a9ed 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -114,7 +114,7 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
                        -- because they are unconditionally wrong
                        -- Moreover, if any of the insolubles are givens, stop right there
                        -- ignoring nested errors, because the code is inaccessible
-  = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
+  = do { let (given, other) = partitionBag (isGivenOrSolved . cc_flavor) insols
              insol_implics  = filterBag ic_insol implics
        ; if isEmptyBag given
          then do { mapBagM_ (reportInsoluble ctxt) other
@@ -123,7 +123,10 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
 
   | otherwise          -- No insoluble ones
   = ASSERT( isEmptyBag insols )
-    do { let (ambigs, non_ambigs) = partition     is_ambiguous (bagToList flats)
+    do { let flat_evs = bagToList $ mapBag to_wev flats
+             to_wev ct | Wanted wl <- cc_flavor ct = mkEvVarX (cc_id ct) wl
+                       | otherwise = panic "reportTidyWanteds: unsolved is not wanted!"
+             (ambigs, non_ambigs) = partition     is_ambiguous flat_evs
        	     (tv_eqs, others)     = partitionWith is_tv_eq     non_ambigs
 
        ; groupErrs (reportEqErrs ctxt) tv_eqs
@@ -153,16 +156,19 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
 		  where   
                      pred = evVarOfPred d
 
-reportInsoluble :: ReportErrCtxt -> FlavoredEvVar -> TcM ()
-reportInsoluble ctxt (EvVarX ev flav)
-  | Just (ty1, ty2) <- getEqPredTys_maybe (evVarPred ev)
+reportInsoluble :: ReportErrCtxt -> Ct -> TcM ()
+-- Precondition: insolubles are always NonCanonicals! 
+reportInsoluble ctxt ct
+  | ev <- cc_id ct
+  , flav <- cc_flavor ct 
+  , Just (ty1, ty2) <- getEqPredTys_maybe (evVarPred ev)
   = setCtFlavorLoc flav $
     do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg }
        ; reportEqErr ctxt2 ty1 ty2 }
   | otherwise
-  = pprPanic "reportInsoluble" (pprEvVarWithType ev)
+  = pprPanic "reportInsoluble" (pprEvVarWithType (cc_id ct))
   where
-    inaccessible_msg | Given loc GivenOrig <- flav
+    inaccessible_msg | Given loc GivenOrig <- (cc_flavor ct)
                        -- If a GivenSolved then we should not report inaccessible code
                      = hang (ptext (sLit "Inaccessible code in"))
                           2 (ppr (ctLocOrigin loc))
@@ -176,7 +182,7 @@ reportFlat ctxt flats origin
        ; unless (null ips)    $ reportIPErrs     ctxt ips    origin
        ; unless (null irreds) $ reportIrredsErrs ctxt irreds origin }
   where
-    (dicts, eqs, ips, irreds) = go_many (map predTypePredTree flats)
+    (dicts, eqs, ips, irreds) = go_many (map classifyPredType flats)
 
     go_many []     = ([], [], [], [])
     go_many (t:ts) = (as ++ as', bs ++ bs', cs ++ cs', ds ++ ds')
@@ -318,7 +324,7 @@ getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp
   -- don't add the extra expected/actual message
   | act `eqType` ty1 && exp `eqType` ty2 = empty
   | exp `eqType` ty1 && act `eqType` ty2 = empty
-  | otherwise                                = mkExpectedActualMsg act exp
+  | otherwise                            = mkExpectedActualMsg act exp
 
 getWantedEqExtra orig _ _ = pprArising orig
 
@@ -842,22 +848,26 @@ find_thing tidy_env ignore_it (ATyVar tv ty)
 
 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 
-warnDefaulting :: [FlavoredEvVar] -> Type -> TcM ()
+warnDefaulting :: [Ct] -> Type -> TcM ()
 warnDefaulting wanteds default_ty
   = do { warn_default <- woptM Opt_WarnTypeDefaults
        ; env0 <- tcInitTidyEnv
        ; let wanted_bag = listToBag wanteds
              tidy_env = tidyFreeTyVars env0 $
-                        tyVarsOfEvVarXs wanted_bag
-             tidy_wanteds = mapBag (tidyFlavoredEvVar tidy_env) wanted_bag
-             (loc, ppr_wanteds) = pprWithArising (map get_wev (bagToList tidy_wanteds))
+                        tyVarsOfCts wanted_bag
+             tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag
+             (loc, ppr_wanteds) = pprWithArising (map mk_wev (bagToList tidy_wanteds))
              warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
                                 <+> quotes (ppr default_ty))
                             2 ppr_wanteds
        ; setCtLoc loc $ warnTc warn_default warn_msg }
-  where
-    get_wev (EvVarX ev (Wanted loc)) = EvVarX ev loc    -- Yuk
-    get_wev ev = pprPanic "warnDefaulting" (ppr ev)
+  where mk_wev :: Ct -> WantedEvVar 
+        mk_wev ct 
+           | ev <- cc_id ct 
+           , Wanted wloc <- cc_flavor ct
+           = EvVarX ev wloc -- must return a WantedEvVar 
+        mk_wev _ct = panic "warnDefaulting: encountered non-wanted for defaulting"
+
 \end{code}
 
 Note [Runtime skolems]
@@ -874,7 +884,7 @@ are created by in RtClosureInspect.zonkRTTIType.
 %************************************************************************
 
 \begin{code}
-solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
+solverDepthErrorTcS :: Int -> [Ct] -> TcS a
 solverDepthErrorTcS depth stack
   | null stack	    -- Shouldn't happen unless you say -fcontext-stack=0
   = wrapErrTcS $ failWith msg
@@ -891,8 +901,8 @@ solverDepthErrorTcS depth stack
     msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 
-flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
-flattenForAllErrorTcS fl ty _bad_eqs
+flattenForAllErrorTcS :: CtFlavor -> TcType -> TcS a
+flattenForAllErrorTcS fl ty
   = wrapErrTcS        $ 
     setCtFlavorLoc fl $ 
     do { env0 <- tcInitTidyEnv
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index e1ab27c3b2..ce6b48c7fa 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -206,6 +206,10 @@ data ZonkEnv
 	-- Only *type* abstraction is done by side effect
 	-- Is only consulted lazily; hence knot-tying
 
+instance Outputable ZonkEnv where 
+  ppr (ZonkEnv _ _ty_env var_env) = vcat (map ppr (varEnvElts var_env))
+
+
 emptyZonkEnv :: ZonkEnv
 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv emptyVarEnv
 
@@ -1078,7 +1082,7 @@ zonkEvTerm env (EvCoercionBox co) = do { co' <- zonkTcLCoToLCo env co
                                        ; return (EvCoercionBox co') }
 zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
                                     do { co' <- zonkTcLCoToLCo env co
-                                       ; return (EvCast (zonkIdOcc env v) co') }
+                                       ; return (mkEvCast (zonkIdOcc env v) co') }
 zonkEvTerm env (EvTupleSel v n)   = return (EvTupleSel (zonkIdOcc env v) n)
 zonkEvTerm env (EvTupleMk vs)     = return (EvTupleMk (map (zonkIdOcc env) vs))
 zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
@@ -1225,10 +1229,14 @@ zonkTypeZapping tv
 
 
 zonkTcLCoToLCo :: ZonkEnv -> LCoercion -> TcM LCoercion
+-- NB: zonking often reveals that the coercion is an identity
+--     in which case the Refl-ness can propagate up to the top
+--     which in turn gives more efficient desugaring.  So it's
+--     worth using the 'mk' smart constructors on the RHS
 zonkTcLCoToLCo env co
   = go co
   where
-    go (CoVarCo cv)         = return (CoVarCo (zonkEvVarOcc env cv))
+    go (CoVarCo cv)         = return (mkEqVarLCo (zonkEvVarOcc env cv))
     go (Refl ty)            = do { ty' <- zonkTcTypeToType env ty
                                  ; return (Refl ty') }
     go (TyConAppCo tc cos)  = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') }
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index a4e87345f4..62ad43d4e7 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -7,15 +7,15 @@
 -- for details
 
 module TcInteract ( 
-     solveInteract, solveInteractGiven, solveInteractWanted,
-     AtomicInert, tyVarsOfInert, 
-     InertSet, emptyInert, updInertSet, extractUnsolved, solveOne,
+     solveInteractWanted, -- Solves [WantedEvVar]
+     solveInteractGiven,  -- Solves [EvVar],GivenLoc
+     solveInteractCts,    -- Solves [Cts]
   ) where  
 
 #include "HsVersions.h"
 
 
-import BasicTypes 
+import BasicTypes ()
 import TcCanonical
 import VarSet
 import Type
@@ -23,14 +23,15 @@ import Unify
 
 import Id 
 import Var
+import VarEnv ( ) -- unitVarEnv, mkInScopeSet
 
 import TcType
 import HsBinds
 
-import Inst( tyVarsOfEvVar )
 import Class
 import TyCon
 import Name
+import IParam
 
 import FunDeps
 
@@ -43,274 +44,175 @@ import TcSMonad
 import Maybes( orElse )
 import Bag
 
+import Control.Monad ( foldM )
+import TrieMap
+
 import Control.Monad( when )
-import Unique
 import UniqFM
 import FastString ( sLit ) 
 import DynFlags
 \end{code}
-
-Note [InertSet invariants]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An InertSet is a bag of canonical constraints, with the following invariants:
-
-  1 No two constraints react with each other. 
-    
-    A tricky case is when there exists a given (solved) dictionary 
-    constraint and a wanted identical constraint in the inert set, but do 
-    not react because reaction would create loopy dictionary evidence for 
-    the wanted. See note [Recursive instances and superclases]
-
-  2 Given equalities form an idempotent substitution [none of the
-    given LHS's occur in any of the given RHS's or reactant parts]
-
-  3 Wanted equalities also form an idempotent substitution
-
-  4 The entire set of equalities is acyclic.
-
-  5 Wanted dictionaries are inert with the top-level axiom set 
-
-  6 Equalities of the form tv1 ~ tv2 always have a touchable variable
-    on the left (if possible).
-
-  7 No wanted constraints tv1 ~ tv2 with tv1 touchable. Such constraints
-    will be marked as solved right before being pushed into the inert set. 
-    See note [Touchables and givens].
-
-  8 No Given constraint mentions a touchable unification variable, but 
-    Given/Solved may do so. 
-
-  9 Given constraints will also have their superclasses in the inert set, 
-    but Given/Solved will not. 
- 
-Note that 6 and 7 are /not/ enforced by canonicalization but rather by 
-insertion in the inert list, ie by TcInteract. 
-
-During the process of solving, the inert set will contain some
-previously given constraints, some wanted constraints, and some given
-constraints which have arisen from solving wanted constraints. For
-now we do not distinguish between given and solved constraints.
-
-Note that we must switch wanted inert items to given when going under an
-implication constraint (when in top-level inference mode).
-
-\begin{code}
-
-data CCanMap a = CCanMap { cts_given   :: UniqFM CanonicalCts
-                                          -- Invariant: all Given
-                         , cts_derived :: UniqFM CanonicalCts 
-                                          -- Invariant: all Derived
-                         , cts_wanted  :: UniqFM CanonicalCts } 
-                                          -- Invariant: all Wanted
-
-cCanMapToBag :: CCanMap a -> CanonicalCts 
-cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap)
-  where rest_wder = foldUFM unionBags rest_der  (cts_wanted cmap) 
-        rest_der  = foldUFM unionBags emptyCCan (cts_derived cmap)
-
-emptyCCanMap :: CCanMap a 
-emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wanted = emptyUFM } 
-
-updCCanMap:: Uniquable a => (a,CanonicalCt) -> CCanMap a -> CCanMap a 
-updCCanMap (a,ct) cmap 
-  = case cc_flavor ct of 
-      Wanted {}  -> cmap { cts_wanted  = insert_into (cts_wanted cmap)  } 
-      Given {}   -> cmap { cts_given   = insert_into (cts_given cmap)   }
-      Derived {} -> cmap { cts_derived = insert_into (cts_derived cmap) }
-  where 
-    insert_into m = addToUFM_C unionBags m a (singleCCan ct)
-
-getRelevantCts :: Uniquable a => a -> CCanMap a -> (CanonicalCts, CCanMap a) 
--- Gets the relevant constraints and returns the rest of the CCanMap
-getRelevantCts a cmap 
-    = let relevant = lookup (cts_wanted cmap) `unionBags`
-                     lookup (cts_given cmap)  `unionBags`
-                     lookup (cts_derived cmap) 
-          residual_map = cmap { cts_wanted  = delFromUFM (cts_wanted cmap) a
-                              , cts_given   = delFromUFM (cts_given cmap) a
-                              , cts_derived = delFromUFM (cts_derived cmap) a }
-      in (relevant, residual_map) 
-  where
-    lookup map = lookupUFM map a `orElse` emptyCCan
-
-extractUnsolvedCMap :: CCanMap a -> (CanonicalCts, CCanMap a)
--- Gets the wanted or derived constraints and returns a residual
--- CCanMap with only givens.
-extractUnsolvedCMap cmap =
-  let wntd = foldUFM unionBags emptyCCan (cts_wanted cmap)
-      derd = foldUFM unionBags emptyCCan (cts_derived cmap)
-  in (wntd `unionBags` derd, 
-      cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM })
-
-
--- See Note [InertSet invariants]
-data InertSet 
-  = IS { inert_eqs          :: CanonicalCts               -- Equalities only (CTyEqCan)
-       , inert_dicts        :: CCanMap Class              -- Dictionaries only
-       , inert_ips          :: CCanMap (IPName Name)      -- Implicit parameters
-       , inert_irreds       :: CanonicalCts               -- Irreducible predicates
-       , inert_frozen       :: CanonicalCts
-       , inert_funeqs       :: CCanMap TyCon              -- Type family equalities only
-               -- This representation allows us to quickly get to the relevant 
-               -- inert constraints when interacting a work item with the inert set.
-       }
-
-tyVarsOfInert :: InertSet -> TcTyVarSet 
-tyVarsOfInert (IS { inert_eqs    = eqs
-                  , inert_dicts  = dictmap
-                  , inert_ips    = ipmap
-                  , inert_irreds = irreds
-                  , inert_frozen = frozen
-                  , inert_funeqs = funeqmap }) = tyVarsOfCanonicals cts
-  where
-    cts = eqs `andCCan` frozen `andCCan` irreds `andCCan` cCanMapToBag dictmap
-              `andCCan` cCanMapToBag ipmap `andCCan` cCanMapToBag funeqmap
-
-instance Outputable InertSet where
-  ppr is = vcat [ vcat (map ppr (Bag.bagToList $ inert_eqs is))
-                , vcat (map ppr (Bag.bagToList $ inert_irreds is)) 
-                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is)))
-                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is))) 
-                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_funeqs is)))
-                , text "Frozen errors =" <+> -- Clearly print frozen errors
-                    vcat (map ppr (Bag.bagToList $ inert_frozen is))
-                ]
-                       
-emptyInert :: InertSet
-emptyInert = IS { inert_eqs    = Bag.emptyBag
-                , inert_frozen = Bag.emptyBag
-                , inert_irreds = Bag.emptyBag
-                , inert_dicts  = emptyCCanMap
-                , inert_ips    = emptyCCanMap
-                , inert_funeqs = emptyCCanMap }
-
-updInertSet :: InertSet -> AtomicInert -> InertSet 
-updInertSet is item 
-  | isCTyEqCan item                     -- Other equality 
-  = let eqs' = inert_eqs is `Bag.snocBag` item
-    in is { inert_eqs = eqs' } 
-  | Just cls <- isCDictCan_Maybe item   -- Dictionary 
-  = is { inert_dicts = updCCanMap (cls,item) (inert_dicts is) } 
-  | Just x  <- isCIPCan_Maybe item      -- IP 
-  = is { inert_ips   = updCCanMap (x,item) (inert_ips is) }  
-  | isCIrredEvCan item                     -- Presently-irreducible evidence
-  = is { inert_irreds = inert_irreds is `Bag.snocBag` item }
-  | Just tc <- isCFunEqCan_Maybe item   -- Function equality 
-  = is { inert_funeqs = updCCanMap (tc,item) (inert_funeqs is) }
-  | otherwise 
-  = is { inert_frozen = inert_frozen is `Bag.snocBag` item }
-
-extractUnsolved :: InertSet -> (InertSet, CanonicalCts)
--- Postcondition: the returned canonical cts are either Derived, or Wanted.
-extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds}) 
-  = let is_solved  = is { inert_eqs    = solved_eqs
-                        , inert_dicts  = solved_dicts
-                        , inert_ips    = solved_ips
-                        , inert_irreds = solved_irreds
-                        , inert_frozen = emptyCCan
-                        , inert_funeqs = solved_funeqs }
-    in (is_solved, unsolved)
-
-  where (unsolved_eqs, solved_eqs)       = Bag.partitionBag (not.isGivenOrSolvedCt) eqs
-        (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenOrSolvedCt) irreds
-        (unsolved_ips, solved_ips)       = extractUnsolvedCMap (inert_ips is) 
-        (unsolved_dicts, solved_dicts)   = extractUnsolvedCMap (inert_dicts is) 
-        (unsolved_funeqs, solved_funeqs) = extractUnsolvedCMap (inert_funeqs is) 
-
-        unsolved = unsolved_eqs `unionBags` inert_frozen is `unionBags` unsolved_irreds `unionBags`
-                   unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs
-\end{code}
-
-%*********************************************************************
-%*                                                                   * 
+**********************************************************************
+*                                                                    * 
 *                      Main Interaction Solver                       *
 *                                                                    *
 **********************************************************************
 
-Note [Basic plan] 
-~~~~~~~~~~~~~~~~~
-1. Canonicalise (unary)
-2. Pairwise interaction (binary)
-    * Take one from work list 
-    * Try all pair-wise interactions with each constraint in inert
-   
-   As an optimisation, we prioritize the equalities both in the 
-   worklist and in the inerts. 
+Note [Basic Simplifier Plan] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-3. Try to solve spontaneously for equalities involving touchables 
-4. Top-level interaction (binary wrt top-level)
-   Superclass decomposition belongs in (1), see note [Adding superclasses]
+1. Pick an element from the WorkList if there exists one with depth 
+   less thanour context-stack depth. 
 
+2. Run it down the 'stage' pipeline. Stages are: 
+      - canonicalization
+      - inert reactions
+      - spontaneous reactions
+      - top-level intreactions
+   Each stage returns a StopOrContinue and may have sideffected 
+   the inerts or worklist.
+  
+   The threading of the stages is as follows: 
+      - If (Stop) is returned by a stage then we start again from Step 1. 
+      - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to 
+        the next stage in the pipeline. 
+4. If the element has survived (i.e. ContinueWith x) the last stage 
+   then we add him in the inerts and jump back to Step 1.
+
+If in Step 1 no such element exists, we have exceeded our context-stack 
+depth and will simply fail.
 \begin{code}
-type AtomicInert = CanonicalCt     -- constraint pulled from InertSet
-type WorkItem    = CanonicalCt     -- constraint pulled from WorkList
-
-------------------------
-data StopOrContinue 
-  = Stop			-- Work item is consumed
-  | ContinueWith WorkItem	-- Not consumed
-
-instance Outputable StopOrContinue where
-  ppr Stop             = ptext (sLit "Stop")
-  ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w
-
--- Results after interacting a WorkItem as far as possible with an InertSet
-data StageResult
-  = SR { sr_inerts     :: InertSet
-           -- The new InertSet to use (REPLACES the old InertSet)
-       , sr_new_work   :: WorkList
-           -- Any new work items generated (should be ADDED to the old WorkList)
-           -- Invariant: 
-           --    sr_stop = Just workitem => workitem is *not* in sr_inerts and
-           --                               workitem is inert wrt to sr_inerts
-       , sr_stop       :: StopOrContinue
-       }
 
-instance Outputable StageResult where
-  ppr (SR { sr_inerts = inerts, sr_new_work = work, sr_stop = stop })
-    = ptext (sLit "SR") <+> 
-      braces (sep [ ptext (sLit "inerts =") <+> ppr inerts <> comma
-             	  , ptext (sLit "new work =") <+> ppr work <> comma
-             	  , ptext (sLit "stop =") <+> ppr stop])
-
-type SubGoalDepth = Int	  -- Starts at zero; used to limit infinite
-     		    	  -- recursion of sub-goals
-type SimplifierStage = SubGoalDepth -> WorkItem -> InertSet -> TcS StageResult 
-
--- Combine a sequence of simplifier 'stages' to create a pipeline 
-runSolverPipeline :: SubGoalDepth
-                  -> [(String, SimplifierStage)]
-		  -> InertSet -> WorkItem 
-                  -> TcS (InertSet, WorkList)
--- Precondition: non-empty list of stages 
-runSolverPipeline depth pipeline inerts workItem
-  = do { traceTcS "Start solver pipeline" $ 
-            vcat [ ptext (sLit "work item =") <+> ppr workItem
-                 , ptext (sLit "inerts    =") <+> ppr inerts]
-
-       ; let itr_in = SR { sr_inerts = inerts
-                         , sr_new_work = emptyWorkList
-                         , sr_stop = ContinueWith workItem }
-       ; itr_out <- run_pipeline pipeline itr_in
-       ; let new_inert 
-              = case sr_stop itr_out of 
-       	          Stop              -> sr_inerts itr_out
-                  ContinueWith item -> sr_inerts itr_out `updInertSet` item
-       ; return (new_inert, sr_new_work itr_out) }
+solveInteractCts :: [Ct] -> TcS ()
+solveInteractCts cts 
+  = do { evvar_cache <- getTcSEvVarCacheMap
+       ; (cts_thinner, new_evvar_cache) <- add_cts_in_cache evvar_cache cts
+       ; traceTcS "solveInteractCts" (vcat [ text "cts_original =" <+> ppr cts, 
+                                             text "cts_thinner  =" <+> ppr cts_thinner
+                                           ])
+       ; setTcSEvVarCacheMap new_evvar_cache 
+       ; updWorkListTcS (appendWorkListCt cts_thinner) >> solveInteract }
+ 
+  where add_cts_in_cache evvar_cache = foldM solve_or_cache ([],evvar_cache)
+        solve_or_cache :: ([Ct],TypeMap (EvVar,CtFlavor)) 
+                       -> Ct
+                       -> TcS ([Ct],TypeMap (EvVar,CtFlavor))
+        solve_or_cache (acc_cts,acc_cache) ct
+          | isIPPred pty
+          = return (ct:acc_cts,acc_cache) -- Do not use the cache, 
+                                          -- nor update it for IPPreds due to subtle shadowing
+          | Just (ev',fl') <- lookupTM pty acc_cache
+          , fl' `canSolve` fl
+          , isWanted fl
+          = do { setEvBind ev (EvId ev')
+               ; return (acc_cts,acc_cache) }
+          | otherwise -- If it's a given keep it in the work list, even if it exists in the cache!
+          = return (ct:acc_cts, alterTM pty (\_ -> Just (ev,fl)) acc_cache)
+          where fl = cc_flavor ct
+                ev = cc_id ct
+                pty = evVarPred ev
+
+
+solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () 
+solveInteractGiven gloc evs
+  = solveInteractCts (map mk_noncan evs)
+  where mk_noncan ev = CNonCanonical { cc_id = ev
+                                     , cc_flavor = Given gloc GivenOrig 
+                                     , cc_depth = 0 }
+
+solveInteractWanted :: [WantedEvVar] -> TcS ()
+-- Solve these wanteds along with current inerts and wanteds!
+solveInteractWanted wevs
+  = solveInteractCts (map mk_noncan wevs) 
+  where mk_noncan (EvVarX v w) 
+          = CNonCanonical { cc_id = v, cc_flavor = Wanted w, cc_depth = 0 }
+
+
+-- The main solver loop implements Note [Basic Simplifier Plan]
+---------------------------------------------------------------
+solveInteract :: TcS ()
+-- Returns the final InertSet in TcS, WorkList will be eventually empty.
+solveInteract
+  = do { dyn_flags <- getDynFlags
+       ; let max_depth = ctxtStkDepth dyn_flags
+             solve_loop
+              = do { sel <- selectNextWorkItem max_depth
+                   ; case sel of 
+                      NoWorkRemaining     -- Done, successfuly (modulo frozen)
+                        -> return ()
+                      MaxDepthExceeded ct -- Failure, depth exceeded
+                        -> solverDepthErrorTcS (cc_depth ct) [ct]
+                      NextWorkItem ct     -- More work, loop around!
+                        -> runSolverPipeline thePipeline ct >> solve_loop }
+       ; solve_loop }
+
+type WorkItem = Ct
+type SimplifierStage = WorkItem -> TcS StopOrContinue
+
+continueWith :: WorkItem -> TcS StopOrContinue
+continueWith work_item = return (ContinueWith work_item) 
+
+data SelectWorkItem 
+       = NoWorkRemaining      -- No more work left (effectively we're done!)
+       | MaxDepthExceeded Ct  -- More work left to do but this constraint has exceeded
+                              -- the max subgoal depth and we must stop 
+       | NextWorkItem Ct      -- More work left, here's the next item to look at 
+
+selectNextWorkItem :: SubGoalDepth -- Max depth allowed
+                   -> TcS SelectWorkItem
+selectNextWorkItem max_depth
+  = updWorkListTcS_return pick_next
   where 
-    run_pipeline :: [(String, SimplifierStage)]
-                 -> StageResult -> TcS StageResult
-    run_pipeline [] itr                         = return itr
-    run_pipeline _  itr@(SR { sr_stop = Stop }) = return itr
-
-    run_pipeline ((name,stage):stages) 
-                 (SR { sr_new_work = accum_work
-                     , sr_inerts   = inerts
-                     , sr_stop     = ContinueWith work_item })
-      = do { itr <- stage depth work_item inerts 
-           ; traceTcS ("Stage result (" ++ name ++ ")") (ppr itr)
-           ; let itr' = itr { sr_new_work = accum_work `unionWorkList` sr_new_work itr }
-           ; run_pipeline stages itr' }
+    pick_next :: WorkList -> (SelectWorkItem, WorkList)
+    -- A simple priorititization of equalities (for now)
+    -- --------------------------------------------------------
+    pick_next wl@(WorkList { wl_eqs = eqs, wl_rest = rest })
+      = case (eqs,rest) of
+          ([],[])                        -- No more work
+              -> (NoWorkRemaining,wl)
+          ((ct:cts),_)
+            | cc_depth ct > max_depth  -- Depth exceeded
+            -> (MaxDepthExceeded ct,wl)
+            | otherwise                -- Equality work 
+            -> (NextWorkItem ct, wl { wl_eqs = cts })
+          ([],(ct:cts))
+            | cc_depth ct > max_depth  -- Depth exceeded
+            -> (MaxDepthExceeded ct,wl)
+            | otherwise                -- Non-equality work
+           -> (NextWorkItem ct, wl {wl_rest = cts})
+
+runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline 
+                  -> WorkItem                   -- The work item 
+                  -> TcS () 
+-- Run this item down the pipeline, leaving behind new work and inerts
+runSolverPipeline pipeline workItem 
+  = do { initial_is <- getTcSInerts 
+       ; traceTcS "Start solver pipeline {" $ 
+                  vcat [ ptext (sLit "work item = ") <+> ppr workItem 
+                       , ptext (sLit "inerts    = ") <+> ppr initial_is]
+
+       ; final_res  <- run_pipeline pipeline (ContinueWith workItem)
+
+       ; final_is <- getTcSInerts
+       ; case final_res of 
+           Stop            -> do { traceTcS "End solver pipeline (discharged) }" 
+                                       (ptext (sLit "inerts    = ") <+> ppr final_is)
+                                 ; return () }
+           ContinueWith ct -> do { traceTcS "End solver pipeline (not discharged) }" $
+                                       vcat [ ptext (sLit "final_item = ") <+> ppr ct
+                                            , ptext (sLit "inerts     = ") <+> ppr final_is]
+                                 ; updInertSetTcS ct }
+       }
+  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue -> TcS StopOrContinue
+        run_pipeline [] res = return res 
+        run_pipeline _ Stop = return Stop 
+        run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)
+          = do { traceTcS ("runStage " ++ stg_name ++ " {")
+                          (text "workitem   = " <+> ppr ct) 
+               ; res <- stg ct 
+               ; traceTcS ("end stage " ++ stg_name ++ " }") empty
+               ; run_pipeline stgs res 
+               }
 \end{code}
 
 Example 1:
@@ -337,175 +239,26 @@ React with (a ~ Int)   ==> IR (ContinueWith (F Int ~ b)) True []
 React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canonicalize and get nothing
 
 \begin{code}
--- Main interaction solver: we fully solve the worklist 'in one go', 
--- returning an extended inert set.
---
--- See Note [Touchables and givens].
-solveInteractGiven :: InertSet -> GivenLoc -> [EvVar] -> TcS InertSet
-solveInteractGiven inert gloc evs
-  = do { (_, inert_ret) <- solveInteract inert $ listToBag $
-                           map mk_given evs
-       ; return inert_ret }
-  where
-    flav = Given gloc GivenOrig
-    mk_given ev = mkEvVarX ev flav
-
-solveInteractWanted :: InertSet -> [WantedEvVar] -> TcS InertSet
-solveInteractWanted inert wvs
-  = do { (_,inert_ret) <- solveInteract inert $ listToBag $
-                          map wantedToFlavored wvs
-       ; return inert_ret }
-
-solveInteract :: InertSet -> Bag FlavoredEvVar -> TcS (Bool, InertSet)
--- Post: (True,  inert_set) means we managed to discharge all constraints
---                          without actually doing any interactions!
---       (False, inert_set) means some interactions occurred
-solveInteract inert ws 
-  = do { dyn_flags <- getDynFlags
-       ; sctx <- getTcSContext
-
-       ; traceTcS "solveInteract, before clever canonicalization:" $
-         vcat [ text "ws = " <+>  ppr (mapBag (\(EvVarX ev ct)
-                                                   -> (ct,evVarPred ev)) ws)
-              , text "inert = " <+> ppr inert ]
-
-       ; can_ws <- mkCanonicalFEVs ws
-
-       ; (flag, inert_ret)
-           <- foldrWorkListM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) can_ws
-
-       ; traceTcS "solveInteract, after clever canonicalization (and interaction):" $
-         vcat [ text "No interaction happened = " <+> ppr flag
-              , text "inert_ret = " <+> ppr inert_ret ]
-
-       ; return (flag, inert_ret) }
-
-tryPreSolveAndInteract :: SimplContext
-                       -> DynFlags
-                       -> CanonicalCt
-                       -> (Bool, InertSet)
-                       -> TcS (Bool, InertSet)
--- Returns: True if it was able to discharge this constraint AND all previous ones
-tryPreSolveAndInteract sctx dyn_flags ct (all_previous_discharged, inert)
-  = do { let inert_cts = get_inert_cts (predTypePredTree (evVarPred ev_var))
-
-       ; this_one_discharged <- 
-           if isCFrozenErr ct then 
-               return False
-           else
-               dischargeFromCCans inert_cts ev_var fl
-
-       ; if this_one_discharged
-         then return (all_previous_discharged, inert)
-
-         else do
-       { inert_ret <- solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) ct inert
-       ; return (False, inert_ret) } }
-
-  where
-    ev_var = cc_id ct
-    fl = cc_flavor ct 
-
-    get_inert_cts (ClassPred clas _)
-      | simplEqsOnly sctx = emptyCCan
-      | otherwise         = fst (getRelevantCts clas (inert_dicts inert))
-    get_inert_cts (IPPred {})
-      = emptyCCan -- We must not do the same thing for IParams, because (contrary
-                  -- to dictionaries), work items /must/ override inert items.
-                 -- See Note [Overriding implicit parameters] in TcInteract.
-    get_inert_cts (EqPred {})
-      = inert_eqs inert `unionBags` cCanMapToBag (inert_funeqs inert)
-    get_inert_cts (TuplePred ts)
-      = andCCans $ map get_inert_cts ts
-    get_inert_cts (IrredPred {})
-      = inert_irreds inert
-
-dischargeFromCCans :: CanonicalCts -> EvVar -> CtFlavor -> TcS Bool
--- See if this (pre-canonicalised) work-item is identical to a 
--- one already in the inert set. Reasons:
---    a) Avoid creating superclass constraints for millions of incoming (Num a) constraints
---    b) Termination for improve_eqs in TcSimplify.simpl_loop
-dischargeFromCCans cans ev fl
-  = Bag.foldrBag discharge_ct (return False) cans
-  where 
-    the_pred = evVarPred ev
-
-    discharge_ct :: CanonicalCt -> TcS Bool -> TcS Bool
-    discharge_ct ct _rest
-      | evVarPred (cc_id ct) `eqPred` the_pred
-      , cc_flavor ct `canSolve` fl
-      = do { when (isWanted fl) $ setEvBind ev (EvId (cc_id ct))
-           	 -- Deriveds need no evidence
-    	         -- For Givens, we already have evidence, and we don't need it twice 
-           ; return True }
-
-    discharge_ct _ct rest = rest
+thePipeline :: [(String,SimplifierStage)]
+thePipeline = [ ("canonicalization",        canonicalizationStage)
+                -- If ContinueWith, will be canonical and fully rewritten wrt inert eqs
+              , ("interact the inert eqs", interactWithInertEqsStage)
+                -- If ContinueWith, will be wanted/derived eq or non-eq
+                -- but can't rewrite not can be rewritten by the inerts
+              , ("spontaneous solve",       spontaneousSolveStage)
+                -- If ContinueWith its not spontaneously solved equality
+              , ("interact with inerts",    interactWithInertsStage)
+              , ("top-level reactions",     topReactionsStage) ]
 \end{code}
 
-Note [Avoiding the superclass explosion] 
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
-This note now is not as significant as it used to be because we no
-longer add the superclasses of Wanted as Derived, except only if they
-have equality superclasses or superclasses with functional
-dependencies. The fear was that hundreds of identical wanteds would
-give rise each to the same superclass or equality Derived's which
-would lead to a blo-up in the number of interactions.
-
-Instead, what we do with tryPreSolveAndCanon, is when we encounter a
-new constraint, we very quickly see if it can be immediately
-discharged by a class constraint in our inert set or the previous
-canonicals. If so, we add nothing to the returned canonical
-constraints.
 
 \begin{code}
-solveOne :: WorkItem -> InertSet -> TcS InertSet 
-solveOne workItem inerts 
-  = do { dyn_flags <- getDynFlags
-       ; solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) workItem inerts
-       }
-
------------------
-solveInteractWithDepth :: (Int, Int, [WorkItem])
-                       -> WorkList -> InertSet -> TcS InertSet
-solveInteractWithDepth ctxt@(max_depth,n,stack) ws inert
-  | isEmptyWorkList ws
-  = return inert
-
-  | n > max_depth 
-  = solverDepthErrorTcS n stack
 
-  | otherwise 
-  = do { traceTcS "solveInteractWithDepth" $ 
-              vcat [ text "Current depth =" <+> ppr n
-                   , text "Max depth =" <+> ppr max_depth
-                   , text "ws =" <+> ppr ws ]
+-- The canonicalization stage, see TcCanonical for details
+----------------------------------------------------------
+canonicalizationStage :: SimplifierStage
+canonicalizationStage = TcCanonical.canonicalize 
 
-
-       ; foldrWorkListM (solveOneWithDepth ctxt) inert ws }
-              -- use foldr to preserve the order
-
-------------------
--- Fully interact the given work item with an inert set, and return a
--- new inert set which has assimilated the new information.
-solveOneWithDepth :: (Int, Int, [WorkItem])
-                  -> WorkItem -> InertSet -> TcS InertSet
-solveOneWithDepth (max_depth, depth, stack) work inert
-  = do { traceFireTcS depth (text "Solving {" <+> ppr work)
-       ; (new_inert, new_work) <- runSolverPipeline depth thePipeline inert work
-         
-	 -- Recursively solve the new work generated 
-         -- from workItem, with a greater depth
-       ; res_inert <- solveInteractWithDepth (max_depth, depth+1, work:stack) new_work new_inert 
-
-       ; traceFireTcS depth (text "Done }" <+> ppr work) 
-
-       ; return res_inert }
-
-thePipeline :: [(String,SimplifierStage)]
-thePipeline = [ ("interact with inert eqs", interactWithInertEqsStage)
-              , ("interact with inerts",    interactWithInertsStage)
-              , ("spontaneous solve",       spontaneousSolveStage)
-              , ("top-level reactions",     topReactionsStage) ]
 \end{code}
 
 *********************************************************************************
@@ -541,72 +294,136 @@ Case 3: IP improvement work
 
 \begin{code}
 spontaneousSolveStage :: SimplifierStage 
-spontaneousSolveStage depth workItem inerts 
+spontaneousSolveStage workItem
   = do { mSolve <- trySpontaneousSolve workItem
+       ; spont_solve mSolve } 
+  where spont_solve SPCantSolve = continueWith workItem 
+        spont_solve (SPSolved workItem')
+          = do { bumpStepCountTcS
+               ; traceFireTcS (cc_depth workItem) $
+                 ptext (sLit "Spontaneous") 
+                           <+> parens (ppr (cc_flavor workItem)) <+> ppr workItem
+               -- If original was /not/ given we may have to kick out now-rewritable inerts
+               ; when (not (isGivenOrSolvedCt workItem)) $
+                 kickOutRewritableInerts workItem'
+               -- Add solved guy in inerts anyway
+               ; updInertSetTcS workItem'
+               -- .. and Stop 
+               ; return Stop }
+
+kickOutRewritableInerts :: Ct -> TcS () 
+-- Pre:  ct is a CTyEqCan 
+-- Post: the TcS monad is left with the thinner non-rewritable inerts; the 
+--       rewritable end up in the worklist
+kickOutRewritableInerts ct 
+  = do { wl <- modifyInertTcS (kick_out_rewritable ct)
+
+         -- Rewrite the rewritable solved on the spot and stick them back in the inerts
+
+{- DV: I am commenting out the solved story altogether because I did not see any performance
+       improvement compared to just kicking out the solved ones any way. In fact there were
+       situations where performance got worse.
+
+       ; let subst = unitVarEnv (cc_tyvar ct) (ct, mkEqVarLCo (cc_id ct))
+             inscope = mkInScopeSet $ tyVarsOfCt ct
+       ; solved_rewritten <- mapBagM (rewrite_solved (subst,inscope)) solved_out
+       ; _unused <- modifyInertTcS (add_new_solveds solved_rewritten)
+      
+-}
+       ; traceTcS "Kick out" (ppr ct $$ ppr wl)
+       ; updWorkListTcS (unionWorkList wl) }
+{- 
+  where rewrite_solved inert_eqs solved_ct 
+          = do { (new_ev,_) <- rewriteFromInertEqs inert_eqs fl ev
+               ; mk_canonical new_ev }
+          where fl = cc_flavor solved_ct
+                ev = cc_id solved_ct
+                d  = cc_depth solved_ct
+                mk_canonical new_ev
+                  -- A bit of an overkill to call the canonicalizer, but ok ...
+                  = do { let new_pty = evVarPred new_ev
+                       ; r <- canEvVar new_ev (classifyPredType new_pty) d fl
+                       ; case r of
+                           Stop -> pprPanic "kickOutRewritableInerts" $ 
+                                   vcat [ text "Should never Stop, solved constraint IS canonical!"
+                                        , text "Orig (solved)     =" <+> ppr solved_ct
+                                        , text "Rewritten (solved)=" <+> ppr new_pty ]
+                           ContinueWith ct -> return ct }
+        add_new_solveds cts is = ((), is { inert_solved = new_solved })
+           where orig_solveds     = inert_solved is
+                 do_one slvmap ct = let ct_key = mkPredKeyForTypeMap ct
+                                    in alterTM ct_key (\_ -> Just ct) slvmap
+                 new_solved       = foldlBag do_one orig_solveds cts
+-}
 
-       ; case mSolve of 
-           SPCantSolve -> -- No spontaneous solution for him, keep going
-               return $ SR { sr_new_work   = emptyWorkList
-                           , sr_inerts     = inerts
-                           , sr_stop       = ContinueWith workItem }
-
-           SPSolved workItem'
-               | not (isGivenOrSolvedCt workItem) 
-	       	 -- Original was wanted or derived but we have now made him 
-                 -- given so we have to interact him with the inerts due to
-                 -- its status change. This in turn may produce more work.
-		 -- We do this *right now* (rather than just putting workItem'
-		 -- back into the work-list) because we've solved 
-               -> do { bumpStepCountTcS
-	       	     ; traceFireTcS depth (ptext (sLit "Spontaneous (w/d)") <+> ppr workItem)
-                     ; (new_inert, new_work) <- runSolverPipeline depth
-                             [ ("recursive interact with inert eqs", interactWithInertEqsStage)
-                             , ("recursive interact with inerts", interactWithInertsStage)
-                             ] inerts workItem'
-                     ; return $ SR { sr_new_work = new_work 
-                                   , sr_inerts   = new_inert -- will include workItem' 
-                                   , sr_stop     = Stop }
-                     }
-               | otherwise 
-                   -> -- Original was given; he must then be inert all right, and
-                      -- workList' are all givens from flattening
-                      do { bumpStepCountTcS
-	       	         ; traceFireTcS depth (ptext (sLit "Spontaneous (g)") <+> ppr workItem)
-                         ; return $ SR { sr_new_work = emptyWorkList
-                                       , sr_inerts   = inerts `updInertSet` workItem' 
-                                       , sr_stop     = Stop } }
-           SPError -> -- Return with no new work
-               return $ SR { sr_new_work = emptyWorkList
-                           , sr_inerts   = inerts
-                           , sr_stop     = Stop }
-       }
+kick_out_rewritable :: Ct -> InertSet -> (WorkList,InertSet)
+kick_out_rewritable ct (IS { inert_eqs    = eqmap
+                           , inert_eq_tvs = inscope
+                           , inert_dicts  = dictmap
+                           , inert_ips    = ipmap
+                           , inert_funeqs = funeqmap
+                           , inert_irreds = irreds
+                           , inert_frozen = frozen
+                           } )
+  = (kicked_out, remaining)
+  where
+
+    kicked_out = WorkList { wl_eqs  = eqs_out ++ bagToList feqs_out
+                          , wl_rest = bagToList (fro_out `andCts` dicts_out 
+                                        `andCts` ips_out `andCts` irs_out) }
+  
+    remaining = IS { inert_eqs = eqs_in
+                   , inert_eq_tvs = inscope -- keep the same, safe and cheap
+                   , inert_dicts = dicts_in
+                   , inert_ips = ips_in
+                   , inert_funeqs = feqs_in
+                   , inert_irreds = irs_in
+                   , inert_frozen = fro_in 
+                   }
+
+    fl = cc_flavor ct
+    tv = cc_tyvar ct
+
+    (eqs_out,   eqs_in)   = partitionEqMap rewritable eqmap
+    (ips_out,   ips_in)   = partitionCCanMap rewritable ipmap 
+
+    (feqs_out,  feqs_in)  = partitionCtTypeMap rewritable funeqmap
+    (dicts_out, dicts_in) = partitionCCanMap rewritable dictmap
+
+    (irs_out,   irs_in)   = partitionBag rewritable irreds
+    (fro_out,   fro_in)   = partitionBag rewritable frozen
+    rewritable ct = (fl `canRewrite` cc_flavor ct) && 
+                    (tv `elemVarSet` tyVarsOfCt ct)
+
+
+                             
+data SPSolveResult = SPCantSolve
+                   | SPSolved WorkItem 
 
-data SPSolveResult = SPCantSolve | SPSolved WorkItem | SPError
 -- SPCantSolve means that we can't do the unification because e.g. the variable is untouchable
 -- SPSolved workItem' gives us a new *given* to go on 
--- SPError means that it's completely impossible to solve this equality, eg due to a kind error
-
 
 -- @trySpontaneousSolve wi@ solves equalities where one side is a
 -- touchable unification variable.
 --     	    See Note [Touchables and givens] 
 trySpontaneousSolve :: WorkItem -> TcS SPSolveResult
-trySpontaneousSolve workItem@(CTyEqCan { cc_id = eqv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi })
+trySpontaneousSolve workItem@(CTyEqCan { cc_id = eqv, cc_flavor = gw
+                                       , cc_tyvar = tv1, cc_rhs = xi, cc_depth = d })
   | isGivenOrSolved gw
   = return SPCantSolve
   | Just tv2 <- tcGetTyVar_maybe xi
   = do { tch1 <- isTouchableMetaTyVar tv1
        ; tch2 <- isTouchableMetaTyVar tv2
        ; case (tch1, tch2) of
-           (True,  True)  -> trySpontaneousEqTwoWay eqv gw tv1 tv2
-           (True,  False) -> trySpontaneousEqOneWay eqv gw tv1 xi
-           (False, True)  -> trySpontaneousEqOneWay eqv gw tv2 (mkTyVarTy tv1)
+           (True,  True)  -> trySpontaneousEqTwoWay d eqv gw tv1 tv2
+           (True,  False) -> trySpontaneousEqOneWay d eqv gw tv1 xi
+           (False, True)  -> trySpontaneousEqOneWay d eqv gw tv2 (mkTyVarTy tv1)
 	   _ -> return SPCantSolve }
   | otherwise
   = do { tch1 <- isTouchableMetaTyVar tv1
-       ; if tch1 then trySpontaneousEqOneWay eqv gw tv1 xi
-                 else do { traceTcS "Untouchable LHS, can't spontaneously solve workitem:" 
-                                    (ppr workItem) 
+       ; if tch1 then trySpontaneousEqOneWay d eqv gw tv1 xi
+                 else do { traceTcS "Untouchable LHS, can't spontaneously solve workitem:" $
+                           ppr workItem 
                          ; return SPCantSolve }
        }
 
@@ -616,40 +433,34 @@ trySpontaneousSolve workItem@(CTyEqCan { cc_id = eqv, cc_flavor = gw, cc_tyvar =
 trySpontaneousSolve _ = return SPCantSolve
 
 ----------------
-trySpontaneousEqOneWay :: EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult
+trySpontaneousEqOneWay :: SubGoalDepth 
+                       -> EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult
 -- tv is a MetaTyVar, not untouchable
-trySpontaneousEqOneWay eqv gw tv xi	
+trySpontaneousEqOneWay d eqv gw tv xi	
   | not (isSigTyVar tv) || isTyVarTy xi 
   = do { let kxi = typeKind xi -- NB: 'xi' is fully rewritten according to the inerts 
                                -- so we have its more specific kind in our hands
        ; is_sub_kind <- kxi `isSubKindTcS` tyVarKind tv
        ; if is_sub_kind then
-             solveWithIdentity eqv gw tv xi
+             solveWithIdentity d eqv gw tv xi
          else return SPCantSolve
-{-
-         else if tyVarKind tv `isSubKind` kxi then
-             return SPCantSolve -- kinds are compatible but we can't solveWithIdentity this way
-                                -- This case covers the  a_touchable :: * ~ b_untouchable :: ?? 
-                                -- which has to be deferred or floated out for someone else to solve 
-                                -- it in a scope where 'b' is no longer untouchable.
-         else do { addErrorTcS KindError gw (mkTyVarTy tv) xi -- See Note [Kind errors]
-                 ; return SPError }
--}
        }
   | otherwise -- Still can't solve, sig tyvar and non-variable rhs
   = return SPCantSolve
 
 ----------------
-trySpontaneousEqTwoWay :: EqVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult
+trySpontaneousEqTwoWay :: SubGoalDepth 
+                       -> EqVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult
 -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here
-trySpontaneousEqTwoWay eqv gw tv1 tv2
+
+trySpontaneousEqTwoWay d eqv gw tv1 tv2
   = do { k1_sub_k2 <- k1 `isSubKindTcS` k2
        ; if k1_sub_k2 && nicer_to_update_tv2
-         then solveWithIdentity eqv gw tv2 (mkTyVarTy tv1)
+         then solveWithIdentity d eqv gw tv2 (mkTyVarTy tv1)
          else do
        { k2_sub_k1 <- k2 `isSubKindTcS` k1
        ; MASSERT( k2_sub_k1 )  -- they were unified in TcCanonical
-       ; solveWithIdentity eqv gw tv1 (mkTyVarTy tv2) } }
+       ; solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2) } }
   where
     k1 = tyVarKind tv1
     k2 = tyVarKind tv2
@@ -743,7 +554,8 @@ unification variables as RHS of type family equations: F xis ~ alpha.
 \begin{code}
 ----------------
 
-solveWithIdentity :: EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult
+solveWithIdentity :: SubGoalDepth 
+                  -> EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult
 -- Solve with the identity coercion 
 -- Precondition: kind(xi) is a sub-kind of kind(tv)
 -- Precondition: CtFlavor is Wanted or Derived
@@ -751,23 +563,45 @@ solveWithIdentity :: EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult
 --     must work for Derived as well as Wanted
 -- Returns: workItem where 
 --        workItem = the new Given constraint
-solveWithIdentity eqv wd tv xi 
+solveWithIdentity d eqv wd tv xi 
   = do { traceTcS "Sneaky unification:" $ 
                        vcat [text "Coercion variable:  " <+> ppr wd, 
                              text "Coercion:           " <+> pprEq (mkTyVarTy tv) xi,
                              text "Left  Kind is     : " <+> ppr (typeKind (mkTyVarTy tv)),
                              text "Right Kind is     : " <+> ppr (typeKind xi)
-                  ]
+                            ]
 
        ; setWantedTyBind tv xi
        ; let refl_xi = mkReflCo xi
-       ; eqv_given <- newGivenEqVar (mkTyVarTy tv) xi refl_xi
+
+       ; let solved_fl = mkSolvedFlavor wd UnkSkol 
+       ; eqv_given <- newGivenEqVar solved_fl (mkTyVarTy tv) xi refl_xi
 
        ; when (isWanted wd) (setEqBind eqv refl_xi)
            -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)'
-       ; return $ SPSolved (CTyEqCan { cc_id = eqv_given
-                                     , cc_flavor = mkSolvedFlavor wd UnkSkol
-                                     , cc_tyvar  = tv, cc_rhs = xi }) }
+       ; return $ SPSolved (CTyEqCan { cc_id     = eqv_given
+                                     , cc_flavor = solved_fl
+                                     , cc_tyvar  = tv, cc_rhs = xi, cc_depth = d }) }
+\end{code}
+
+*********************************************************************************
+*                                                                               *
+*                         Interact with inert equalities                        *
+*                                                                               *
+*********************************************************************************
+
+\begin{code}
+
+interactWithInertEqsStage  :: WorkItem -> TcS StopOrContinue
+interactWithInertEqsStage  ct 
+  | isCTyEqCan ct
+  = do { kickOutRewritableInerts ct
+       ; if isGivenOrSolved (cc_flavor ct) then updInertSetTcS ct >> return Stop
+         else continueWith ct } -- If wanted or derived we may spontaneously solve him
+  | isCNonCanonical ct
+  = pprPanic "Interact with inerts eqs stage met non-canonical constraint!" (ppr ct)
+  | otherwise
+  = continueWith ct
 \end{code}
 
 
@@ -804,171 +638,68 @@ or, equivalently,
 
 \begin{code}
 -- Interaction result of  WorkItem <~> AtomicInert
-data InteractResult
-   = IR { ir_stop         :: StopOrContinue
-            -- Stop
-            --   => Reagent (work item) consumed.
-            -- ContinueWith new_reagent
-            --   => Reagent transformed but keep gathering interactions. 
-            --      The transformed item remains inert with respect 
-            --      to any previously encountered inerts.
-
-        , ir_inert_action :: InertAction
-            -- Whether the inert item should remain in the InertSet.
-
-        , ir_new_work     :: WorkList
-            -- new work items to add to the WorkList
-
-        , ir_fire :: Maybe String    -- Tells whether a rule fired, and if so what
-        }
-
--- What to do with the inert reactant.
-data InertAction = KeepInert | DropInert 
-
-mkIRContinue :: String -> WorkItem -> InertAction -> WorkList -> TcS InteractResult
-mkIRContinue rule wi keep newWork 
-  = return $ IR { ir_stop = ContinueWith wi, ir_inert_action = keep
-                , ir_new_work = newWork, ir_fire = Just rule }
-
-mkIRStopK :: String -> WorkList -> TcS InteractResult
-mkIRStopK rule newWork
-  = return $ IR { ir_stop = Stop, ir_inert_action = KeepInert
-                , ir_new_work = newWork, ir_fire = Just rule }
 
-mkIRStopD :: String -> WorkList -> TcS InteractResult
-mkIRStopD rule newWork
-  = return $ IR { ir_stop = Stop, ir_inert_action = DropInert
-                , ir_new_work = newWork, ir_fire = Just rule }
+data InteractResult 
+    = IRWorkItemConsumed { ir_fire :: String } 
+    | IRInertConsumed    { ir_fire :: String } 
+    | IRKeepGoing        { ir_fire :: String }
 
-noInteraction :: Monad m => WorkItem -> m InteractResult
-noInteraction wi
-  = return $ IR { ir_stop = ContinueWith wi, ir_inert_action = KeepInert
-                , ir_new_work = emptyWorkList, ir_fire = Nothing }
+irWorkItemConsumed :: String -> TcS InteractResult
+irWorkItemConsumed str = return (IRWorkItemConsumed str) 
 
-data WhichComesFromInert = LeftComesFromInert | RightComesFromInert 
-     -- See Note [Efficient Orientation] 
+irInertConsumed :: String -> TcS InteractResult
+irInertConsumed str = return (IRInertConsumed str) 
 
+irKeepGoing :: String -> TcS InteractResult 
+irKeepGoing str = return (IRKeepGoing str) 
+-- You can't discard neither workitem or inert, but you must keep 
+-- going. It's possible that new work is waiting in the TcS worklist. 
 
----------------------------------------------------
--- Interact a single WorkItem with the equalities of an inert set as
--- far as possible, i.e. until we get a Stop result from an individual
--- reaction (i.e. when the WorkItem is consumed), or until we've
--- interact the WorkItem with the entire equalities of the InertSet
 
-interactWithInertEqsStage :: SimplifierStage 
-interactWithInertEqsStage depth workItem inert
-  = Bag.foldrBagM (interactNext depth) initITR (inert_eqs inert)
-                        -- use foldr to preserve the order          
-  where
-    initITR = SR { sr_inerts   = inert { inert_eqs = emptyCCan }
-                 , sr_new_work = emptyWorkList
-                 , sr_stop     = ContinueWith workItem }
-
----------------------------------------------------
--- Interact a single WorkItem with *non-equality* constraints in the inert set. 
--- Precondition: equality interactions must have already happened, hence we have 
--- to pick up some information from the incoming inert, before folding over the 
--- "Other" constraints it contains!
-
-interactWithInertsStage :: SimplifierStage
-interactWithInertsStage depth workItem inert
-  = let (relevant, inert_residual) = getISRelevant workItem inert 
-        initITR = SR { sr_inerts   = inert_residual
-                     , sr_new_work = emptyWorkList
-                     , sr_stop     = ContinueWith workItem } 
-    in Bag.foldrBagM (interactNext depth) initITR relevant 
-                        -- use foldr to preserve the order
-  where 
-    getISRelevant :: CanonicalCt -> InertSet -> (CanonicalCts, InertSet) 
-    getISRelevant (CFrozenErr {}) is = (emptyCCan, is)
-                  -- Nothing s relevant; we have alread interacted
-                  -- it with the equalities in the inert set
-
-    getISRelevant (CDictCan { cc_class = cls } ) is
-      = let (relevant, residual_map) = getRelevantCts cls (inert_dicts is)
-        in (relevant, is { inert_dicts = residual_map }) 
-    getISRelevant (CFunEqCan { cc_fun = tc } ) is 
-      = let (relevant, residual_map) = getRelevantCts tc (inert_funeqs is) 
-        in (relevant, is { inert_funeqs = residual_map })
-    getISRelevant (CIPCan { cc_ip_nm = nm }) is 
-      = let (relevant, residual_map) = getRelevantCts nm (inert_ips is)
-        in (relevant, is { inert_ips = residual_map }) 
-    getISRelevant (CIrredEvCan {}) is
-      = (inert_irreds is, is { inert_irreds = emptyCCan })
-    -- An equality, finally, may kick everything except equalities out 
-    -- because we have already interacted the equalities in interactWithInertEqsStage
-    getISRelevant _eq_ct is  -- Equality, everything is relevant for this one 
-                             -- TODO: if we were caching variables, we'd know that only 
-                             --       some are relevant. Experiment with this for now. 
-      = let cts = cCanMapToBag (inert_ips is) `unionBags`
-                    cCanMapToBag (inert_dicts is) `unionBags`
-                    cCanMapToBag (inert_funeqs is) `unionBags`
-                    inert_irreds is
-        in (cts, is { inert_dicts  = emptyCCanMap
-                    , inert_ips    = emptyCCanMap
-                    , inert_funeqs = emptyCCanMap
-                    , inert_irreds = emptyBag })
-
-interactNext :: SubGoalDepth -> AtomicInert -> StageResult -> TcS StageResult 
-interactNext depth inert it
-  | ContinueWith work_item <- sr_stop it
-  = do { let inerts = sr_inerts it 
-
-       ; IR { ir_new_work = new_work, ir_inert_action = inert_action
-            , ir_fire = fire_info, ir_stop = stop } 
-            <- interactWithInert inert work_item
-
-       ; let mk_msg rule 
-      	       = text rule <+> keep_doc
-      	         <+> vcat [ ptext (sLit "Inert =") <+> ppr inert
-      	                  , ptext (sLit "Work =")  <+> ppr work_item
-      	                  , ppUnless (isEmptyWorkList new_work) $
-                            ptext (sLit "New =") <+> ppr new_work ]
-             keep_doc = case inert_action of
-                 	  KeepInert -> ptext (sLit "[keep]")
-                 	  DropInert -> ptext (sLit "[drop]")
-       ; case fire_info of
-           Just rule -> do { bumpStepCountTcS
-                           ; traceFireTcS depth (mk_msg rule) }
-           Nothing  -> return ()
-
-       -- New inerts depend on whether we KeepInert or not 
-       ; let inerts_new = case inert_action of
-                            KeepInert -> inerts `updInertSet` inert
-                            DropInert -> inerts
-
-       ; return $ SR { sr_inerts   = inerts_new
-                     , sr_new_work = sr_new_work it `unionWorkList` new_work
-                     , sr_stop     = stop } }
-  | otherwise 
-  = return $ it { sr_inerts = (sr_inerts it) `updInertSet` inert }
-
--- Do a single interaction of two constraints.
-interactWithInert :: AtomicInert -> WorkItem -> TcS InteractResult
-interactWithInert inert workItem 
+interactWithInertsStage :: WorkItem -> TcS StopOrContinue 
+-- Precondition: if the workitem is a CTyEqCan then it will not be able to 
+-- react with anything at this stage. 
+interactWithInertsStage wi 
   = do { ctxt <- getTcSContext
-       ; let is_allowed  = allowedInteraction (simplEqsOnly ctxt) inert workItem 
-
-       ; if is_allowed then 
-              doInteractWithInert inert workItem 
-          else 
-              noInteraction workItem 
-       }
-
-allowedInteraction :: Bool -> AtomicInert -> WorkItem -> Bool 
--- Allowed interactions 
-allowedInteraction eqs_only (CDictCan {})    (CDictCan {})    = not eqs_only
-allowedInteraction eqs_only (CIPCan {})      (CIPCan {})      = not eqs_only
-allowedInteraction eqs_only (CIrredEvCan {}) (CIrredEvCan {}) = not eqs_only
-allowedInteraction _ _ _ = True 
-
+       ; if simplEqsOnly ctxt then 
+             return (ContinueWith wi)
+         else 
+             extractRelevantInerts wi >>= 
+               foldlBagM interact_next (ContinueWith wi) }
+
+  where interact_next Stop atomic_inert 
+          = updInertSetTcS atomic_inert >> return Stop
+        interact_next (ContinueWith wi) atomic_inert 
+          = do { ir <- doInteractWithInert atomic_inert wi
+               ; let mk_msg rule keep_doc 
+                       = text rule <+> keep_doc
+      	                 <+> vcat [ ptext (sLit "Inert =") <+> ppr atomic_inert
+      	                          , ptext (sLit "Work =")  <+> ppr wi ]
+               ; case ir of 
+                   IRWorkItemConsumed { ir_fire = rule } 
+                       -> do { bumpStepCountTcS
+                             ; traceFireTcS (cc_depth wi) 
+                                            (mk_msg rule (text "WorkItemConsumed"))
+                             ; updInertSetTcS atomic_inert
+                             ; return Stop } 
+                   IRInertConsumed { ir_fire = rule }
+                       -> do { bumpStepCountTcS
+                             ; traceFireTcS (cc_depth atomic_inert) 
+                                            (mk_msg rule (text "InertItemConsumed"))
+                             ; return (ContinueWith wi) }
+                   IRKeepGoing {} -- Should we do a bumpStepCountTcS? No for now.
+                       -> do { updInertSetTcS atomic_inert
+                             ; return (ContinueWith wi) }
+               }
+   
 --------------------------------------------
-doInteractWithInert :: CanonicalCt -> CanonicalCt -> TcS InteractResult
--- Identical class constraints.
+data WhichComesFromInert = LeftComesFromInert | RightComesFromInert
 
+doInteractWithInert :: Ct -> Ct -> TcS InteractResult
+-- Identical class constraints.
 doInteractWithInert
   inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) 
-   workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 })
+   workItem@(CDictCan { cc_id = _d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 })
 
   | cls1 == cls2  
   = do { let pty1 = mkClassPred cls1 tys1
@@ -976,6 +707,9 @@ doInteractWithInert
              inert_pred_loc     = (pty1, pprFlavorArising fl1)
              work_item_pred_loc = (pty2, pprFlavorArising fl2)
 
+       ; traceTcS "doInteractWithInert" (vcat [ text "inertItem = " <+> ppr inertItem
+                                              , text "workItem  = " <+> ppr workItem ])
+
        ; any_fundeps 
            <- if isGivenOrSolved fl1 && isGivenOrSolved fl2 then return Nothing
               -- NB: We don't create fds for given (and even solved), have not seen a useful
@@ -991,90 +725,20 @@ doInteractWithInert
            -- No Functional Dependencies 
            Nothing             
                | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem
-               | otherwise         -> noInteraction workItem
+               | otherwise         -> irKeepGoing "NOP"
 
            -- Actual Functional Dependencies
-           Just (rewritten_tys2,cos2,fd_work) 
-               | not (eqTypes tys1 rewritten_tys2) 
-               -- Standard thing: create derived fds and keep on going. Importantly we don't
+           Just (_rewritten_tys2,_cos2,fd_work)
+              -- Standard thing: create derived fds and keep on going. Importantly we don't
                -- throw workitem back in the worklist because this can cause loops. See #5236.
-               -> do { fd_cans <- mkCanonicalFDAsDerived fd_work
-                     ; mkIRContinue "Cls/Cls fundep (not solved)" workItem KeepInert fd_cans }
-
-               -- This WHOLE otherwise branch is an optimization where the fd made the things match
-               | otherwise  
-               , let dict_co = mkTyConAppCo (classTyCon cls1) cos2
-               -> case fl2 of
-                    Given {} 
-                        -> pprPanic "Unexpected given!" (ppr inertItem $$ ppr workItem)
-                           -- The only way to have created a fundep is if the inert was
-                           -- wanted or derived, in which case the workitem can't be given!
-                    Derived {}
-                        -- The types were made to exactly match so we don't need 
-                        -- the workitem any longer.
-                        -> do { fd_cans <- mkCanonicalFDAsDerived fd_work
-                               -- No rewriting really, so let's create deriveds fds
-                              ; mkIRStopK "Cls/Cls fundep (solved)" fd_cans }
-		    Wanted  {} 
-		        | isDerived fl1 
-                            -> do { setEvBind d2 (EvCast d1 dict_co)
-			          ; let inert_w = inertItem { cc_flavor = fl2 }
-			   -- A bit naughty: we take the inert Derived, 
-			   -- turn it into a Wanted, use it to solve the work-item
-			   -- and put it back into the work-list
-			   -- Maybe rather than starting again, we could keep going 
-                           -- with the rewritten workitem, having dropped the inert, but its
-                           -- safe to restart.
-                          
-                           -- Also: we have rewriting so lets create wanted fds
-                                  ; fd_cans <- mkCanonicalFDAsWanted fd_work
-                                  ; mkIRStopD "Cls/Cls fundep (solved)" $ 
-                                    workListFromNonEq inert_w `unionWorkList` fd_cans }
-		        | otherwise
-                        -> do { setEvBind d2 (EvCast d1 dict_co)
-                          -- Rewriting is happening, so we have to create wanted fds
-                              ; fd_cans <- mkCanonicalFDAsWanted fd_work
-                              ; mkIRStopK "Cls/Cls fundep (solved)" fd_cans }
+               -> do { emitFDWorkAsDerived fd_work (cc_depth workItem)
+                     ; irKeepGoing "Cls/Cls (new fundeps)" } -- Just keep going without droping the inert 
        }
   where get_workitem_wloc (Wanted wl)  = wl 
         get_workitem_wloc (Derived wl) = wl 
         get_workitem_wloc (Given {})   = panic "Unexpected given!"
 
 
--- Class constraint and given equality: use the equality to rewrite
--- the class constraint. 
-doInteractWithInert (CTyEqCan { cc_id = eqv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) 
-                    (CDictCan { cc_id = dv, cc_flavor = wfl, cc_class = cl, cc_tyargs = xis }) 
-  | ifl `canRewrite` wfl 
-  , tv `elemVarSet` tyVarsOfTypes xis
-  = do { rewritten_dict <- rewriteDict (eqv,tv,xi) (dv,wfl,cl,xis)
-            -- Continue with rewritten Dictionary because we can only be in the 
-            -- interactWithEqsStage, so the dictionary is inert. 
-       ; mkIRContinue "Eq/Cls" rewritten_dict KeepInert emptyWorkList }
-    
-doInteractWithInert (CDictCan { cc_id = dv, cc_flavor = ifl, cc_class = cl, cc_tyargs = xis }) 
-           workItem@(CTyEqCan { cc_id = eqv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi })
-  | wfl `canRewrite` ifl
-  , tv `elemVarSet` tyVarsOfTypes xis
-  = do { rewritten_dict <- rewriteDict (eqv,tv,xi) (dv,ifl,cl,xis)
-       ; mkIRContinue "Cls/Eq" workItem DropInert (workListFromNonEq rewritten_dict) }
-
--- Irreducible evidence and given equality: use the equality to rewrite
--- the irreducible evidence.
-doInteractWithInert (CTyEqCan { cc_id = eqv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) 
-                    (CIrredEvCan { cc_id = id, cc_flavor = wfl, cc_ty = ty })
-  | ifl `canRewrite` wfl
-  , tv `elemVarSet` tyVarsOfType ty 
-  = do { rewritten_irred <- rewriteIrred (eqv,tv,xi) (id,wfl,ty) 
-       ; mkIRStopK "Eq/Irred" rewritten_irred } 
-
-doInteractWithInert (CIrredEvCan { cc_id = id, cc_flavor = ifl, cc_ty = ty }) 
-           workItem@(CTyEqCan { cc_id = eqv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi })
-  | wfl `canRewrite` ifl
-  , tv `elemVarSet` tyVarsOfType ty
-  = do { rewritten_irred <- rewriteIrred (eqv,tv,xi) (id,ifl,ty) 
-       ; mkIRContinue "Irred/Eq" workItem DropInert rewritten_irred }
-
 -- Two pieces of irreducible evidence: if their types are *exactly identical* we can
 -- rewrite them. We can never improve using this: if we want ty1 :: Constraint and have
 -- ty2 :: Constraint it clearly does not mean that (ty1 ~ ty2)
@@ -1083,22 +747,6 @@ doInteractWithInert (CIrredEvCan { cc_id = id1, cc_flavor = ifl, cc_ty = ty1 })
   | ty1 `eqType` ty2
   = solveOneFromTheOther "Irred/Irred" (EvId id1,ifl) workItem
 
--- Implicit param and given equality: use the equality to rewrite
--- the implicit param.
-doInteractWithInert (CTyEqCan { cc_id = eqv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) 
-                    (CIPCan { cc_id = ipid, cc_flavor = wfl, cc_ip_nm = nm, cc_ip_ty = ty }) 
-  | ifl `canRewrite` wfl
-  , tv `elemVarSet` tyVarsOfType ty 
-  = do { rewritten_ip <- rewriteIP (eqv,tv,xi) (ipid,wfl,nm,ty) 
-       ; mkIRContinue "Eq/IP" rewritten_ip KeepInert emptyWorkList } 
-
-doInteractWithInert (CIPCan { cc_id = ipid, cc_flavor = ifl, cc_ip_nm = nm, cc_ip_ty = ty }) 
-           workItem@(CTyEqCan { cc_id = eqv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi })
-  | wfl `canRewrite` ifl
-  , tv `elemVarSet` tyVarsOfType ty
-  = do { rewritten_ip <- rewriteIP (eqv,tv,xi) (ipid,ifl,nm,ty) 
-       ; mkIRContinue "IP/Eq" workItem DropInert (workListFromNonEq rewritten_ip) }
-
 -- Two implicit parameter constraints.  If the names are the same,
 -- but their types are not, we generate a wanted type equality 
 -- that equates the type (this is "improvement").  
@@ -1112,290 +760,121 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i
 	-- Do not require type equality
 	-- For example, given let ?x::Int = 3 in let ?x::Bool = True in ...
 	--              we must *override* the outer one with the inner one
-    mkIRContinue "IP/IP override" workItem DropInert emptyWorkList
+    irInertConsumed "IP/IP (override inert)"
 
   | nm1 == nm2 && ty1 `eqType` ty2 
   = solveOneFromTheOther "IP/IP" (EvId id1,ifl) workItem 
 
   | nm1 == nm2
   =  	-- See Note [When improvement happens]
-    do { eqv <- newEqVar ty2 ty1 -- See Note [Efficient Orientation]
-       ; let flav = Wanted (combineCtLoc ifl wfl)
-       ; cans <- mkCanonical flav eqv
+    do { let flav = Wanted (combineCtLoc ifl wfl)
+       ; eqv <- newEqVar flav ty2 ty1 -- See Note [Efficient Orientation]
+       ; when (isNewEvVar eqv) $
+              (let ct = CNonCanonical { cc_id     = evc_the_evvar eqv 
+                                      , cc_flavor = flav
+                                      , cc_depth  = cc_depth workItem }
+              in updWorkListTcS (extendWorkListEq ct))
+
        ; case wfl of
            Given   {} -> pprPanic "Unexpected given IP" (ppr workItem)
            Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem)
            Wanted  {} ->
-               do { setEvBind (cc_id workItem)
-                    (EvCast id1 (mkSymCo (mkEqVarLCo eqv)))
-                  ; mkIRStopK "IP/IP interaction (solved)" cans }
-       }
-
--- Never rewrite a given with a wanted equality, and a type function
--- equality can never rewrite an equality. We rewrite LHS *and* RHS 
--- of function equalities so that our inert set exposes everything that 
--- we know about equalities.
-
--- Inert: equality, work item: function equality
-doInteractWithInert (CTyEqCan { cc_id = eqv1, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi1 }) 
-                    (CFunEqCan { cc_id = eqv2, cc_flavor = wfl, cc_fun = tc
-                               , cc_tyargs = args, cc_rhs = xi2 })
-  | ifl `canRewrite` wfl 
-  , tv `elemVarSet` tyVarsOfTypes (xi2:args) -- Rewrite RHS as well
-  = do { rewritten_funeq <- rewriteFunEq (eqv1,tv,xi1) (eqv2,wfl,tc,args,xi2) 
-       ; mkIRStopK "Eq/FunEq" (workListFromEq rewritten_funeq) } 
-         -- Must Stop here, because we may no longer be inert after the rewritting.
-
--- Inert: function equality, work item: equality
-doInteractWithInert (CFunEqCan {cc_id = eqv1, cc_flavor = ifl, cc_fun = tc
-                              , cc_tyargs = args, cc_rhs = xi1 }) 
-           workItem@(CTyEqCan { cc_id = eqv2, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi2 })
-  | wfl `canRewrite` ifl
-  , tv `elemVarSet` tyVarsOfTypes (xi1:args) -- Rewrite RHS as well
-  = do { rewritten_funeq <- rewriteFunEq (eqv2,tv,xi2) (eqv1,ifl,tc,args,xi1) 
-       ; mkIRContinue "FunEq/Eq" workItem DropInert (workListFromEq rewritten_funeq) } 
-         -- One may think that we could (KeepTransformedInert rewritten_funeq) 
-         -- but that is wrong, because it may end up not being inert with respect 
-         -- to future inerts. Example: 
-         -- Original inert = {    F xis ~  [a], b ~ Maybe Int } 
-         -- Work item comes along = a ~ [b] 
-         -- If we keep { F xis ~ [b] } in the inert set we will end up with: 
-         --      { F xis ~ [b], b ~ Maybe Int, a ~ [Maybe Int] } 
-         -- At the end, which is *not* inert. So we should unfortunately DropInert here.
+               do { setEvBind (cc_id workItem) $ 
+                    mkEvCast id1 (mkSymCo (mkTyConAppCo (ipTyCon nm1) [mkEqVarLCo (evc_the_evvar eqv)]))
+                    -- DV: Changing: used to be (mkSymCo (mkEqVarLCo eqv))
+                  ; irWorkItemConsumed "IP/IP (solved by rewriting)" } }
 
 doInteractWithInert (CFunEqCan { cc_id = eqv1, cc_flavor = fl1, cc_fun = tc1
-                               , cc_tyargs = args1, cc_rhs = xi1 }) 
-           workItem@(CFunEqCan { cc_id = eqv2, cc_flavor = fl2, cc_fun = tc2
-                               , cc_tyargs = args2, cc_rhs = xi2 })
-  | tc1 == tc2 && and (zipWith eqType args1 args2) 
-  , Just GivenSolved <- isGiven_maybe fl1 
-  = mkIRContinue "Funeq/Funeq" workItem DropInert emptyWorkList
-  | tc1 == tc2 && and (zipWith eqType args1 args2) 
-  , Just GivenSolved <- isGiven_maybe fl2 
-  = mkIRStopK "Funeq/Funeq" emptyWorkList
-
+                               , cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 }) 
+                    (CFunEqCan { cc_id = eqv2, cc_flavor = fl2, cc_fun = tc2
+                               , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 })
+  | lhss_match  
+  , Just GivenSolved <- isGiven_maybe fl1 -- Inert is solved and we can simply ignore it
+                                          -- when workitem is given/solved
+  , isGivenOrSolved fl2
+  = irInertConsumed "FunEq/FunEq"
+  | lhss_match 
+  , Just GivenSolved <- isGiven_maybe fl2 -- Workitem is solved and we can ignore it when
+                                          -- the inert is given/solved
+  , isGivenOrSolved fl1                 
+  = irWorkItemConsumed "FunEq/FunEq" 
   | fl1 `canSolve` fl2 && lhss_match
-  = do { cans <- rewriteEqLHS LeftComesFromInert  (eqv1,xi1) (eqv2,fl2,xi2) 
-       ; mkIRStopK "FunEq/FunEq" cans } 
+  = do { rewriteEqLHS LeftComesFromInert  (eqv1,xi1) (eqv2,d2,fl2,xi2) 
+       ; irWorkItemConsumed "FunEq/FunEq" }
+
   | fl2 `canSolve` fl1 && lhss_match
-  = do { cans <- rewriteEqLHS RightComesFromInert (eqv2,xi2) (eqv1,fl1,xi1) 
-       ; mkIRContinue "FunEq/FunEq" workItem DropInert cans }
+  = do { rewriteEqLHS RightComesFromInert (eqv2,xi2) (eqv1,d1,fl1,xi1) 
+       ; irInertConsumed "FunEq/FunEq"}
   where
     lhss_match = tc1 == tc2 && eqTypes args1 args2 
 
-doInteractWithInert (CTyEqCan { cc_id = eqv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) 
-           workItem@(CTyEqCan { cc_id = eqv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 })
--- Check for matching LHS 
-  | fl1 `canSolve` fl2 && tv1 == tv2 
-  = do { cans <- rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,fl2,xi2) 
-       ; mkIRStopK "Eq/Eq lhs" cans } 
-
-  | fl2 `canSolve` fl1 && tv1 == tv2 
-  = do { cans <- rewriteEqLHS RightComesFromInert (eqv2,xi2) (eqv1,fl1,xi1) 
-       ; mkIRContinue "Eq/Eq lhs" workItem DropInert cans }
-
--- Check for rewriting RHS 
-  | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfType xi2 
-  = do { rewritten_eq <- rewriteEqRHS (eqv1,tv1,xi1) (eqv2,fl2,tv2,xi2) 
-       ; mkIRStopK "Eq/Eq rhs" rewritten_eq }
-
-  | fl2 `canRewrite` fl1 && tv2 `elemVarSet` tyVarsOfType xi1
-  = do { rewritten_eq <- rewriteEqRHS (eqv2,tv2,xi2) (eqv1,fl1,tv1,xi1) 
-       ; mkIRContinue "Eq/Eq rhs" workItem DropInert rewritten_eq } 
-
-doInteractWithInert (CTyEqCan   { cc_id = eqv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 })
-                    (CFrozenErr { cc_id = eqv2, cc_flavor = fl2 })
-  | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfEvVar eqv2
-  = do { rewritten_frozen <- rewriteFrozen (eqv1, tv1, xi1) (eqv2, fl2)
-       ; mkIRStopK "Frozen/Eq" rewritten_frozen }
-
-doInteractWithInert (CFrozenErr { cc_id = eqv2, cc_flavor = fl2 })
-           workItem@(CTyEqCan   { cc_id = eqv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 })
-  | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfEvVar eqv2
-  = do { rewritten_frozen <- rewriteFrozen (eqv1, tv1, xi1) (eqv2, fl2)
-       ; mkIRContinue "Frozen/Eq" workItem DropInert rewritten_frozen }
-
--- Fall-through case for all other situations
-doInteractWithInert _ workItem = noInteraction workItem
-
--------------------------
--- Equational Rewriting 
-rewriteDict  :: (EqVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt
-rewriteDict (eqv,tv,xi) (dv,gw,cl,xis) 
-  = do { let args = substTysWith [tv] [xi] xis
-             dict_co = mkTyConAppCo con cos 
-               where cos = map (liftCoSubstWith [tv] [cv]) xis   -- xis[tv] ~ xis[xi]
-                     con = classTyCon cl
-                     cv  = mkEqVarLCo eqv
-       ; dv' <- newDictVar cl args 
-       ; case gw of 
-           Wanted {}         -> setEvBind dv  (EvCast dv' (mkSymCo dict_co))
-           Given {}          -> setEvBind dv' (EvCast dv  dict_co)
-           Derived {}        -> return () -- Derived dicts we don't set any evidence
-
-       ; return (CDictCan { cc_id = dv'
-                          , cc_flavor = gw 
-                          , cc_class = cl 
-                          , cc_tyargs = args }) } 
-
-rewriteIrred :: (EqVar,TcTyVar,Xi) -> (EvVar,CtFlavor,TcType) -> TcS WorkList 
-rewriteIrred (eqv,tv,xi) (id,gw,ty)
-  = do { let ty' = substTyWith  [tv] [xi] ty
-             co = liftCoSubstWith [tv] [cv] ty     -- ty[tv] ~ ty[xi]
-               where cv = mkEqVarLCo eqv
-       ; id' <- newEvVar ty' 
-       ; case gw of 
-           Wanted {}         -> setEvBind id  (EvCast id' (mkSymCo co))
-           Given {}          -> setEvBind id' (EvCast id  co) 
-           Derived {}        -> return () -- Derived ips: we don't set any evidence
-
-       ; mkCanonical gw id' }
-
-rewriteIP :: (EqVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt 
-rewriteIP (eqv,tv,xi) (ipid,gw,nm,ty) 
-  = do { let ty' = substTyWith   [tv] [xi] ty
-             ip_co = liftCoSubstWith [tv] [cv] ty     -- ty[tv] ~ ty[xi]
-               where cv = mkEqVarLCo eqv
-       ; ipid' <- newIPVar nm ty' 
-       ; case gw of 
-           Wanted {}         -> setEvBind ipid  (EvCast ipid' (mkSymCo ip_co))
-           Given {}          -> setEvBind ipid' (EvCast ipid  ip_co)
-           Derived {}        -> return () -- Derived ips: we don't set any evidence
-
-       ; return (CIPCan { cc_id = ipid'
-                        , cc_flavor = gw
-                        , cc_ip_nm = nm
-                        , cc_ip_ty = ty' }) }
-   
-rewriteFunEq :: (EqVar,TcTyVar,Xi) -> (EqVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt
-rewriteFunEq (eqv1,tv,xi1) (eqv2,gw, tc,args,xi2)                   -- cv2 :: F args ~ xi2
-  = do { let args'    = substTysWith [tv] [xi1] args
-             xi2'    = substTyWith [tv] [xi1] xi2
-             
-             (fun_co, xi2_co) = (fun_co, xi2_co)
-               where cv1 = mkEqVarLCo eqv1
-                     co_subst = liftCoSubstWith [tv] [cv1]
-                     arg_cos  = map co_subst args
-                     fun_co   = mkTyConAppCo tc arg_cos                -- fun_co :: F args ~ F args'
-        
-                     xi2_co  = co_subst xi2 -- xi2_co :: xi2 ~ xi2'
-
-       ; eqv2' <- newEqVar (mkTyConApp tc args') xi2'
-       ; case gw of 
-           Wanted {} -> setEqBind eqv2
-                          (fun_co `mkTransCo` 
-                             mkEqVarLCo eqv2' `mkTransCo` 
-                             mkSymCo xi2_co)
-           Given {}  -> setEqBind eqv2'
-                          (mkSymCo fun_co `mkTransCo` 
-                             mkEqVarLCo eqv2  `mkTransCo` 
-                             xi2_co)
-           Derived {} -> return () 
-
-       ; return (CFunEqCan { cc_id = eqv2'
-                           , cc_flavor = gw
-                           , cc_tyargs = args'
-                           , cc_fun = tc 
-                           , cc_rhs = xi2' }) }
-
-
-rewriteEqRHS :: (EqVar,TcTyVar,Xi) -> (EqVar,CtFlavor,TcTyVar,Xi) -> TcS WorkList
--- Use the first equality to rewrite the second, flavors already checked. 
--- E.g.          c1 : tv1 ~ xi1   c2 : tv2 ~ xi2
--- rewrites c2 to give
---               c2' : tv2 ~ xi2[xi1/tv1]
--- We must do an occurs check to sure the new constraint is canonical
--- So we might return an empty bag
-rewriteEqRHS (eqv1,tv1,xi1) (eqv2,gw,tv2,xi2) 
-  | Just tv2' <- tcGetTyVar_maybe xi2'
-  , tv2 == tv2'	 -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2
-  = do { when (isWanted gw) $ setEqBind eqv2 (mkSymCo co2')
-       ; return emptyWorkList } 
-  | otherwise
-  = do { eqv2' <- newEqVar (mkTyVarTy tv2) xi2'
-       ; case gw of
-             Wanted {} -> setEqBind eqv2  (mkEqVarLCo eqv2' `mkTransCo` mkSymCo co2')
-             Given {}  -> setEqBind eqv2' (mkEqVarLCo eqv2  `mkTransCo` co2')
-             Derived {} -> return ()
-       ; canEqToWorkList gw eqv2' (mkTyVarTy tv2) xi2' }
-  where 
-    xi2' = substTyWith [tv1] [xi1] xi2 
-    co2' = liftCoSubstWith [tv1] [cv1] xi2  -- xi2 ~ xi2[xi1/tv1]
-      where cv1 = mkEqVarLCo eqv1
 
-rewriteEqLHS :: WhichComesFromInert -> (EqVar,Xi) -> (EqVar,CtFlavor,Xi) -> TcS WorkList
+doInteractWithInert _ _ = irKeepGoing "NOP"
+
+
+rewriteEqLHS :: WhichComesFromInert -> (EqVar,Xi) -> (EqVar,SubGoalDepth,CtFlavor,Xi) -> TcS ()
 -- Used to ineract two equalities of the following form: 
 -- First Equality:   co1: (XXX ~ xi1)  
 -- Second Equality:  cv2: (XXX ~ xi2) 
 -- Where the cv1 `canRewrite` cv2 equality 
 -- We have an option of creating new work (xi1 ~ xi2) OR (xi2 ~ xi1), 
 --    See Note [Efficient Orientation] for that 
-rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,gw,xi2) 
-  = do { eqv2' <- newEqVar xi2 xi1 
+rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2) 
+  = do { delCachedEvVar eqv2 -- Similarly to canonicalization!
+       ; evc <- newEqVar gw xi2 xi1
+       ; let eqv2' = evc_the_evvar evc
        ; case gw of 
-           Wanted {} -> setEqBind eqv2
-                        (mkEqVarLCo eqv1 `mkTransCo` mkSymCo (mkEqVarLCo eqv2'))
-           Given {}  -> setEqBind eqv2'
-                        (mkSymCo (mkEqVarLCo eqv2) `mkTransCo` mkEqVarLCo eqv1)
-           Derived {} -> return ()
-       ; mkCanonical gw eqv2' }
-
-rewriteEqLHS RightComesFromInert (eqv1,xi1) (eqv2,gw,xi2) 
-  = do { eqv2' <- newEqVar xi1 xi2
+           Wanted {} 
+               -> setEqBind eqv2 $ 
+                  mkEqVarLCo eqv1 `mkTransCo` mkSymCo (mkEqVarLCo eqv2')
+           Given {}  
+               -> setEqBind eqv2' $ 
+                  mkSymCo (mkEqVarLCo eqv2) `mkTransCo` mkEqVarLCo eqv1
+           Derived {} 
+               -> return ()
+       ; when (isNewEvVar evc) $ 
+              updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id     = eqv2'
+                                                              , cc_flavor = gw
+                                                              , cc_depth  = d } ) ) }
+
+rewriteEqLHS RightComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2) 
+  = do { delCachedEvVar eqv2 -- Similarly to canonicalization!
+       ; evc <- newEqVar gw xi1 xi2
+       ; let eqv2' = evc_the_evvar evc
        ; case gw of
-           Wanted {} -> setEqBind eqv2
-                        (mkTransCo (mkEqVarLCo eqv1) (mkEqVarLCo eqv2'))
-           Given {}  -> setEqBind eqv2'
-                        (mkSymCo (mkEqVarLCo eqv1) `mkTransCo` mkEqVarLCo eqv2)
-           Derived {} -> return ()
-       ; mkCanonical gw eqv2' }
-
-rewriteFrozen :: (EqVar,TcTyVar,Xi) -> (EqVar,CtFlavor) -> TcS WorkList
-rewriteFrozen (eqv1, tv1, xi1) (eqv2, fl2)
-  = do { eqv2' <- newEqVar ty2a' ty2b'  -- ty2a[xi1/tv1] ~ ty2b[xi1/tv1]
-       ; case fl2 of
-             Wanted {} -> setEqBind eqv2
-                            (co2a'              `mkTransCo`
-                       	       mkEqVarLCo eqv2' `mkTransCo`
-                       	       mkSymCo co2b')
-
-             Given {} -> setEqBind eqv2'
-                           (mkSymCo co2a'     `mkTransCo`
-                              mkEqVarLCo eqv2 `mkTransCo`
-                              co2b')
-
-             Derived {} -> return ()
-
-      ; return (workListFromNonEq $ CFrozenErr { cc_id = eqv2', cc_flavor = fl2 }) }
-  where
-    (ty2a, ty2b) = getEqPredTys (evVarPred eqv2)        -- cv2 : ty2a ~ ty2b
-    ty2a' = substTyWith [tv1] [xi1] ty2a
-    ty2b' = substTyWith [tv1] [xi1] ty2b
-
-    cv1 = mkEqVarLCo eqv1
-    co2a' = liftCoSubstWith [tv1] [cv1] ty2a  -- ty2a ~ ty2a[xi1/tv1]
-    co2b' = liftCoSubstWith [tv1] [cv1] ty2b  -- ty2b ~ ty2b[xi1/tv1]
-
-solveOneFromTheOther_ExtraWork :: String -> (EvTerm, CtFlavor) 
-                               -> CanonicalCt -> WorkList -> TcS InteractResult
--- First argument inert, second argument work-item. They both represent 
--- wanted/given/derived evidence for the *same* predicate so 
--- we can discharge one directly from the other. 
---
--- Precondition: value evidence only (implicit parameters, classes) 
---               not coercion
-solveOneFromTheOther_ExtraWork info (ev_term,ifl) workItem extra_work
+           Wanted {} 
+               -> setEqBind eqv2 $ 
+                  mkEqVarLCo eqv1 `mkTransCo` mkEqVarLCo eqv2'
+           Given {}  
+               -> setEqBind eqv2' $
+                  mkSymCo (mkEqVarLCo eqv1) `mkTransCo` mkEqVarLCo eqv2
+           Derived {} 
+               -> return ()
+
+       ; when (isNewEvVar evc) $
+              updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id = eqv2'
+                                                              , cc_flavor = gw
+                                                              , cc_depth  = d } ) ) }
+
+solveOneFromTheOther :: String             -- Info 
+                     -> (EvTerm, CtFlavor) -- Inert 
+                     -> Ct        -- WorkItem 
+                     -> TcS InteractResult
+-- Preconditions: 
+-- 1) inert and work item represent evidence for the /same/ predicate
+-- 2) ip/class/irred evidence (no coercions) only
+solveOneFromTheOther info (ev_term,ifl) workItem
   | isDerived wfl
-  = mkIRStopK ("Solved[DW] " ++ info) extra_work
+  = irWorkItemConsumed ("Solved[DW] " ++ info)
 
   | isDerived ifl -- The inert item is Derived, we can just throw it away, 
     	      	  -- The workItem is inert wrt earlier inert-set items, 
 		  -- so it's safe to continue on from this point
-  = mkIRContinue ("Solved[DI] " ++ info) workItem DropInert extra_work
+  = irInertConsumed ("Solved[DI] " ++ info)
   
   | Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl
     -- Same if the inert is a GivenSolved -- just get rid of it
-  = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert extra_work
+  = irInertConsumed ("Solved[SI] " ++ info)
 
   | otherwise
   = ASSERT( ifl `canSolve` wfl )
@@ -1403,16 +882,11 @@ solveOneFromTheOther_ExtraWork info (ev_term,ifl) workItem extra_work
     do { when (isWanted wfl) $ setEvBind wid ev_term
            -- Overwrite the binding, if one exists
 	   -- If both are Given, we already have evidence; no need to duplicate
-       ; mkIRStopK ("Solved " ++ info) extra_work }
+       ; irWorkItemConsumed ("Solved " ++ info) }
   where 
      wfl = cc_flavor workItem
      wid = cc_id workItem
 
-
-solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult
-solveOneFromTheOther str evfl ct 
-  = solveOneFromTheOther_ExtraWork str evfl ct emptyWorkList -- extra work is empty 
-
 \end{code}
 
 Note [Superclasses and recursive dictionaries]
@@ -1763,60 +1237,42 @@ we keep the synonym-using RHS without expansion.
 *********************************************************************************
 
 \begin{code}
--- If a work item has any form of interaction with top-level we get this 
+
+topReactionsStage :: SimplifierStage 
+topReactionsStage workItem 
+ = tryTopReact workItem 
+   
+
+tryTopReact :: WorkItem -> TcS StopOrContinue
+tryTopReact wi 
+ = do { inerts <- getTcSInerts
+      ; ctxt   <- getTcSContext
+      ; if simplEqsOnly ctxt then return (ContinueWith wi) -- or Stop?
+        else 
+            do { tir <- doTopReact inerts wi
+               ; case tir of 
+                   NoTopInt 
+                       -> return (ContinueWith wi)
+                   SomeTopInt rule what_next 
+                       -> do { bumpStepCountTcS 
+                             ; traceFireTcS (cc_depth wi) $
+                               ptext (sLit "Top react:") <+> text rule
+                             ; return what_next }
+               } }
+
 data TopInteractResult 
-  = NoTopInt         -- No top-level interaction
-                     -- Equivalent to (SomeTopInt emptyWorkList (ContinueWith work_item))
-  | SomeTopInt 
-      { tir_new_work  :: WorkList	-- Sub-goals or new work (could be given, 
-                                        --                        for superclasses)
-      , tir_new_inert :: StopOrContinue -- The input work item, ready to become *inert* now: 
-      }                       		-- NB: in ``given'' (solved) form if the 
-                              		-- original was wanted or given and instance match
-                              		-- was found, but may also be in wanted form if we 
-                                        -- only reacted with functional dependencies 
-					-- arising from top-level instances.
-
-topReactionsStage :: SimplifierStage
-topReactionsStage depth workItem inerts
-  = do { tir <- tryTopReact inerts workItem
-             -- NB: we pass the inerts as well. See Note [Instance and Given overlap]
-       ; case tir of
-           NoTopInt ->
-               return $ SR { sr_inerts   = inerts
-                           , sr_new_work = emptyWorkList
-                           , sr_stop     = ContinueWith workItem }
-           SomeTopInt tir_new_work tir_new_inert ->
-               do { bumpStepCountTcS
-                  ; traceFireTcS depth (ptext (sLit "Top react")
-                       <+> vcat [ ptext (sLit "Work =") <+> ppr workItem
-                                , ptext (sLit "New =") <+> ppr tir_new_work ])
-                  ; return $ SR { sr_inerts   = inerts
-                           	, sr_new_work = tir_new_work
-                           	, sr_stop     = tir_new_inert
-                           	} }
-       }
+ = NoTopInt
+ | SomeTopInt { tir_rule :: String, tir_new_item :: StopOrContinue }
 
-tryTopReact :: InertSet -> WorkItem -> TcS TopInteractResult 
-tryTopReact inerts workitem 
-  = do {  -- A flag controls the amount of interaction allowed
-          -- See Note [Simplifying RULE lhs constraints]
-         ctxt <- getTcSContext
-       ; if allowedTopReaction (simplEqsOnly ctxt) workitem 
-         then do { traceTcS "tryTopReact / calling doTopReact" (ppr workitem)
-                 ; doTopReact inerts workitem }
-         else return NoTopInt 
-       } 
-
-allowedTopReaction :: Bool -> WorkItem -> Bool
-allowedTopReaction eqs_only (CDictCan {}) = not eqs_only
-allowedTopReaction _        _             = True
 
 doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
--- The work item does not react with the inert set, so try interaction with top-level instances
--- NB: The place to add superclasses in *not* in doTopReact stage. Instead superclasses are 
---     added in the worklist as part of the canonicalisation process. 
--- See Note [Adding superclasses] in TcCanonical.
+
+-- The work item does not react with the inert set, so try interaction
+-- with top-level instances 
+-- NB: The place to add superclasses in *not*
+-- in doTopReact stage. Instead superclasses are added in the worklist
+-- as part of the canonicalisation process. See Note [Adding superclasses].
+
 
 -- Given dictionary
 -- See Note [Given constraint that matches an instance declaration]
@@ -1828,27 +1284,27 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc
                                       , cc_class = cls, cc_tyargs = xis })
   = do { instEnvs <- getInstEnvs
        ; let fd_eqns = improveFromInstEnv instEnvs
-                                                (mkClassPred cls xis, pprArisingAt loc)
+                           (mkClassPred cls xis, pprArisingAt loc)
        ; m <- rewriteWithFunDeps fd_eqns xis loc
        ; case m of
            Nothing -> return NoTopInt
            Just (xis',_,fd_work) ->
                let workItem' = workItem { cc_tyargs = xis' }
                    -- Deriveds are not supposed to have identity (cc_id is unused!)
-               in do { fd_cans <- mkCanonicalFDAsDerived fd_work
-                     ; return $ SomeTopInt { tir_new_work  = fd_cans 
-                                           , tir_new_inert = ContinueWith workItem' }
-                     }
+               in do { emitFDWorkAsDerived fd_work (cc_depth workItem)
+                     ; return $ 
+                       SomeTopInt { tir_rule  = "Derived Cls fundeps" 
+                                  , tir_new_item = ContinueWith workItem' } }
        }
 
-
 -- Wanted dictionary
 doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc)
                                      , cc_class = cls, cc_tyargs = xis })
   -- See Note [MATCHING-SYNONYMS]
   = do { traceTcS "doTopReact" (ppr workItem)
        ; instEnvs <- getInstEnvs
-       ; let fd_eqns = improveFromInstEnv instEnvs $ (mkClassPred cls xis, pprArisingAt loc)
+       ; let fd_eqns = improveFromInstEnv instEnvs 
+                            (mkClassPred cls xis, pprArisingAt loc)
 
        ; any_fundeps <- rewriteWithFunDeps fd_eqns xis loc
        ; case any_fundeps of
@@ -1857,50 +1313,44 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc)
                do { lkup_inst_res  <- matchClassInst inerts cls xis loc
                   ; case lkup_inst_res of
                       GenInst wtvs ev_term
-                          -> doSolveFromInstance wtvs ev_term workItem emptyWorkList
+                          -> doSolveFromInstance wtvs ev_term workItem
                       NoInstance
                           -> return NoTopInt
                   }
            -- Actual Functional Dependencies
-           Just (xis',cos,fd_work) ->
-               do { lkup_inst_res <- matchClassInst inerts cls xis' loc
-                  ; case lkup_inst_res of
-                      NoInstance
-                          -> do { fd_cans <- mkCanonicalFDAsDerived fd_work
-                                ; return $
-                                 SomeTopInt { tir_new_work  = fd_cans
-                                             , tir_new_inert = ContinueWith workItem } }
-                      -- This WHOLE branch is an optimization: we can immediately discharge the dictionary
-                      GenInst wtvs ev_term
-                          -> do { let dict_co = mkTyConAppCo (classTyCon cls) cos
-                                ; fd_cans <- mkCanonicalFDAsWanted fd_work
-                                ; dv' <- newDictVar cls xis'
-                                ; setDictBind dv' ev_term
-                                ; doSolveFromInstance wtvs (EvCast dv' dict_co) workItem fd_cans }
-                  } }
+           Just (_xis',_cos,fd_work) ->
+               do { emitFDWorkAsDerived fd_work (cc_depth workItem)
+                  ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)"
+                                      , tir_new_item = ContinueWith workItem } } }
 
    where doSolveFromInstance :: [WantedEvVar] 
                              -> EvTerm 
-                             -> CanonicalCt 
-                             -> WorkList -> TcS TopInteractResult
+                             -> Ct 
+                             -> TcS TopInteractResult
          -- Precondition: evidence term matches the predicate of cc_id of workItem
-         doSolveFromInstance wtvs ev_term workItem extra_work
+         doSolveFromInstance wtvs ev_term workItem
             | null wtvs
             = do { traceTcS "doTopReact/found nullary instance for" (ppr (cc_id workItem))
                  ; setEvBind (cc_id workItem) ev_term
-                 ; return $ SomeTopInt { tir_new_work  = extra_work
-                                       , tir_new_inert = Stop } }
+                 ; return $ 
+                   SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" 
+                              , tir_new_item = Stop } } -- Don't put him in the inerts
             | otherwise 
-            = do { traceTcS "doTopReact/found non-nullary instance for" (ppr (cc_id workItem))
+            = do { traceTcS "doTopReact/found non-nullary instance for" $ 
+                   ppr (cc_id workItem)
                  ; setEvBind (cc_id workItem) ev_term 
                         -- Solved and new wanted work produced, you may cache the 
                         -- (tentatively solved) dictionary as Solved given.
-                 ; let solved    = workItem { cc_flavor = solved_fl }
-                       solved_fl = mkSolvedFlavor fl UnkSkol  
-                 ; inst_work <- canWanteds wtvs
-                 ; return $ SomeTopInt { tir_new_work  = inst_work `unionWorkList` extra_work
-                                       , tir_new_inert = ContinueWith solved } }
-
+                 ; let solved = workItem { cc_flavor = solved_fl }
+                       solved_fl = mkSolvedFlavor fl UnkSkol
+                 ; let ct_from_wev (EvVarX v fl)
+                           = CNonCanonical { cc_id = v, cc_flavor = Wanted fl
+                                           , cc_depth  = cc_depth workItem + 1 }
+                       wtvs_cts = map ct_from_wev wtvs
+                 ; updWorkListTcS (appendWorkListCt wtvs_cts)
+                 ; return $ 
+                   SomeTopInt { tir_rule     = "Dict/Top (solved, more work)"
+                              , tir_new_item = ContinueWith solved } } -- Cache in inerts the Solved item
 
 -- Type functions
 doTopReact _inerts (CFunEqCan { cc_flavor = fl })
@@ -1923,30 +1373,43 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl
                             -- See Note [Type synonym families] in TyCon
                          coe = mkAxInstCo coe_tc rep_tys 
                    ; case fl of
-                       Wanted {} -> do { eqv' <- newEqVar rhs_ty xi
+                       Wanted {} -> do { evc <- newEqVar fl rhs_ty xi -- Wanted version
+                                       ; let eqv' = evc_the_evvar evc
                                        ; setEqBind eqv (coe `mkTransCo` mkEqVarLCo eqv')
-                                       ; can_cts <- mkCanonical fl eqv'
+                                       ; when (isNewEvVar evc) $ 
+                                            (let ct = CNonCanonical { cc_id = eqv'
+                                                                    , cc_flavor = fl 
+                                                                    , cc_depth = cc_depth workItem + 1} 
+                                             in updWorkListTcS (extendWorkListEq ct))
+
                                        ; let solved = workItem { cc_flavor = solved_fl }
                                              solved_fl = mkSolvedFlavor fl UnkSkol
-                                       ; if isEmptyWorkList can_cts then 
-                                              return (SomeTopInt can_cts Stop) -- No point in caching
-                                         else return $ 
-                                              SomeTopInt { tir_new_work = can_cts
-                                                         , tir_new_inert = ContinueWith solved }
-                                       }
-                       Given {} -> do { eqv' <- newEqVar xi rhs_ty
-                                      ; setEqBind eqv' (mkSymCo (mkEqVarLCo eqv) `mkTransCo` coe)
-                                      ; can_cts <- mkCanonical fl eqv'
+
+                                       ; return $ 
+                                         SomeTopInt { tir_rule = "Fun/Top (solved, more work)"
+                                                    , tir_new_item = ContinueWith solved } } 
+                       -- Cache in inerts the Solved item
+
+                       Given {} -> do { eqv' <- newGivenEqVar fl xi rhs_ty $ 
+                                                mkSymCo (mkEqVarLCo eqv) `mkTransCo` coe
+                                      ; let ct = CNonCanonical { cc_id = eqv'
+                                                               , cc_flavor = fl
+                                                               , cc_depth = cc_depth workItem + 1}  
+                                      ; updWorkListTcS (extendWorkListEq ct) 
+
                                       ; return $ 
-                                        SomeTopInt { tir_new_work = can_cts
-                                                   , tir_new_inert = Stop }
-                                      }
-                       Derived {} -> do { eqv' <- newDerivedId (mkEqPred (xi, rhs_ty))
-                                        ; can_cts <- mkCanonical fl eqv'
+                                        SomeTopInt { tir_rule = "Fun/Top (given)"
+                                                   , tir_new_item = ContinueWith workItem } }
+                       Derived {} -> do { evc <- newEvVar fl (mkEqPred (xi, rhs_ty))
+                                        ; let eqv' = evc_the_evvar evc
+                                        ; when (isNewEvVar evc) $ 
+                                            (let ct = CNonCanonical { cc_id  = eqv'
+                                                                 , cc_flavor = fl
+                                                                 , cc_depth  = cc_depth workItem + 1 } 
+                                             in updWorkListTcS (extendWorkListEq ct)) 
                                         ; return $ 
-                                          SomeTopInt { tir_new_work = can_cts
-                                                     , tir_new_inert = Stop }
-                                        }
+                                          SomeTopInt { tir_rule = "Fun/Top (derived)"
+                                                     , tir_new_item = Stop } }
                    }
        }
 
@@ -2187,15 +1650,18 @@ matchClassInst inerts clas tys loc
                  ; if null theta then
                        return (GenInst [] (EvDFunApp dfun_id tys []))
                    else do
-                     { ev_vars <- instDFunConstraints theta
-                     ; let wevs = [EvVarX w loc | w <- ev_vars]
+                     { evc_vars <- instDFunConstraints theta (Wanted loc)
+                     ; let ev_vars = map evc_the_evvar evc_vars
+                           new_evc_vars = filter isNewEvVar evc_vars 
+                           wevs = map (\v -> EvVarX (evc_the_evvar v) loc) new_evc_vars
+                                  -- wevs are only the real new variables that can be emitted 
                      ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
                  }
         }
    where 
-     givens_for_this_clas :: CanonicalCts
-     givens_for_this_clas = lookupUFM (cts_given (inert_dicts inerts)) clas 
-                            `orElse` emptyCCan
+     givens_for_this_clas :: Cts
+     givens_for_this_clas 
+         = lookupUFM (cts_given (inert_dicts inerts)) clas `orElse` emptyCts
 
      given_overlap :: TcsUntouchables -> Bool
      given_overlap untch = anyBag (matchable untch) givens_for_this_clas
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 29ec51c7cb..6ae5be7811 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -63,8 +63,10 @@ module TcMType (
   zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
   zonkQuantifiedTyVar, zonkQuantifiedTyVars,
   zonkTcType, zonkTcTypes, zonkTcThetaType,
-  zonkTcKind, defaultKindVarToStar,
-  zonkImplication, zonkEvVar, zonkWantedEvVar, zonkFlavoredEvVar,
+
+  zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts,
+  zonkImplication, zonkEvVar, zonkWantedEvVar,
+
   zonkWC, zonkWantedEvVars,
   zonkTcTypeAndSubst,
   tcGetGlobalTyVars, 
@@ -164,7 +166,7 @@ newDict cls tys
        ; return (mkLocalId name (mkClassPred cls tys)) }
 
 predTypeOccName :: PredType -> OccName
-predTypeOccName ty = case predTypePredTree ty of
+predTypeOccName ty = case classifyPredType ty of
     ClassPred cls _ -> mkDictOcc (getOccName cls)
     IPPred ip _     -> mkVarOccFS (ipFastString ip)
     EqPred _ _      -> mkVarOccFS (fsLit "cobox")
@@ -670,19 +672,26 @@ zonkEvVar :: EvVar -> TcM EvVar
 zonkEvVar var = do { ty' <- zonkTcType (varType var)
                    ; return (setVarType var ty') }
 
-zonkFlavoredEvVar :: FlavoredEvVar -> TcM FlavoredEvVar
-zonkFlavoredEvVar (EvVarX ev fl)
-  = do { ev' <- zonkEvVar ev
-       ; fl' <- zonkFlavor fl
-       ; return (EvVarX ev' fl') }
 
 zonkWC :: WantedConstraints -> TcM WantedConstraints
 zonkWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
-  = do { flat'   <- zonkWantedEvVars flat
+  = do { flat'   <- mapBagM zonkCt flat 
        ; implic' <- mapBagM zonkImplication implic
-       ; insol'  <- mapBagM zonkFlavoredEvVar insol
+       ; insol'  <- mapBagM zonkCt insol
        ; return (WC { wc_flat = flat', wc_impl = implic', wc_insol = insol' }) }
 
+zonkCt :: Ct -> TcM Ct 
+-- Zonking a Ct conservatively gives back a CNonCanonical
+zonkCt ct 
+  = do { v'  <- zonkEvVar (cc_id ct)
+       ; fl' <- zonkFlavor (cc_flavor ct)
+       ; return $ 
+         CNonCanonical { cc_id = v'
+                       , cc_flavor = fl'
+                       , cc_depth = cc_depth ct } }
+zonkCts :: Cts -> TcM Cts
+zonkCts = mapBagM zonkCt
+
 zonkWantedEvVars :: Bag WantedEvVar -> TcM (Bag WantedEvVar)
 zonkWantedEvVars = mapBagM zonkWantedEvVar
 
@@ -1217,7 +1226,7 @@ check_pred_ty' _ _ctxt (IPPred _ ty) = checkValidMonoType ty
 check_pred_ty' dflags ctxt t@(TuplePred ts)
   = do { checkTc (xopt Opt_ConstraintKinds dflags)
                  (predTupleErr (predTreePredType t))
-       ; mapM_ (check_pred_ty' dflags ctxt) ts }
+       ; mapM_ (check_pred_ty dflags ctxt) ts }
     -- This case will not normally be executed because without -XConstraintKinds
     -- tuple types are only kind-checked as *
 
@@ -1386,7 +1395,7 @@ growPredTyVars :: TcPredType
                -> TyVarSet	-- The set to extend
 	       -> TyVarSet	-- TyVars of the predicate if it intersects
 	       	  		-- the set, or is implicit parameter
-growPredTyVars pred tvs = go (predTypePredTree pred)
+growPredTyVars pred tvs = go (classifyPredType pred)
   where
     grow pred_tvs | pred_tvs `intersectsVarSet` tvs = pred_tvs
                   | otherwise                       = emptyVarSet
@@ -1394,7 +1403,7 @@ growPredTyVars pred tvs = go (predTypePredTree pred)
     go (IPPred _ ty)     = tyVarsOfType ty -- See Note [Implicit parameters and ambiguity]
     go (ClassPred _ tys) = grow (tyVarsOfTypes tys)
     go (EqPred ty1 ty2)  = grow (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)
-    go (TuplePred ts)    = unionVarSets (map go ts)
+    go (TuplePred ts)    = unionVarSets (map (go . classifyPredType) ts)
     go (IrredPred ty)    = grow (tyVarsOfType ty)
 \end{code}
     
@@ -1727,7 +1736,6 @@ fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty)
 fvTypes :: [Type] -> [TyVar]
 fvTypes tys                = concat (map fvType tys)
 
--------------------
 sizeType :: Type -> Int
 -- Size of a type: the number of variables and constructors
 sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
@@ -1749,12 +1757,12 @@ sizeTypes xs = sum (map sizeType tys)
 -- can't get back to a class constraint, so it's safe
 -- to say "size 0".  See Trac #4200.
 sizePred :: PredType -> Int
-sizePred ty = go (predTypePredTree ty)
+sizePred ty = go (classifyPredType ty)
   where
     go (ClassPred _ tys') = sizeTypes tys'
     go (IPPred {})        = 0
     go (EqPred {})        = 0
-    go (TuplePred ts)     = sum (map go ts)
+    go (TuplePred ts)     = sum (map (go . classifyPredType) ts)
     go (IrredPred ty)     = sizeType ty
 \end{code}
 
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 48f3cf8fd7..5312e681c6 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -150,7 +150,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax
         ifWOptM Opt_WarnImplicitPrelude $
              when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
 
-	tcg_env <- tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
+	tcg_env <- {-# SCC "tcRnImports" #-}
+                   tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
 	setGblEnv tcg_env		$ do {
 
 		-- Load the hi-boot interface for this module, if any
@@ -168,7 +169,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 	tcg_env <- if isHsBoot hsc_src then
 			tcRnHsBootDecls local_decls
 		   else	
-			tcRnSrcDecls boot_iface local_decls ;
+			{-# SCC "tcRnSrcDecls" #-}
+                        tcRnSrcDecls boot_iface local_decls ;
 	setGblEnv tcg_env		$ do {
 
 		-- Report the use of any deprecated things
@@ -420,7 +422,8 @@ tcRnSrcDecls boot_iface decls
 	     --	 * the global env exposes the instances to simplifyTop
 	     --  * the local env exposes the local Ids to simplifyTop, 
 	     --    so that we get better error messages (monomorphism restriction)
-	new_ev_binds <- simplifyTop lie ;
+	new_ev_binds <- {-# SCC "simplifyTop" #-}
+                        simplifyTop lie ;
         traceTc "Tc9" empty ;
 
 	failIfErrsM ;	-- Don't zonk if there have been errors
@@ -441,7 +444,8 @@ tcRnSrcDecls boot_iface decls
             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
 
         (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') 
-            <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
+            <- {-# SCC "zonkTopDecls" #-}
+               zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
         
         let { final_type_env = extendTypeEnvWithIds type_env bind_ids
             ; tcg_env' = tcg_env { tcg_binds    = binds',
@@ -460,7 +464,8 @@ tc_rn_src_decls :: ModDetails
 -- Loops around dealing with each top level inter-splice group 
 -- in turn, until it's dealt with the entire module
 tc_rn_src_decls boot_details ds
- = do { (first_group, group_tail) <- findSplice ds  ;
+ = {-# SCC "tc_rn_src_decls" #-}
+   do { (first_group, group_tail) <- findSplice ds  ;
 		-- If ds is [] we get ([], Nothing)
         
 	-- Deal with decls up to, but not including, the first splice
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index d10d451642..75a80c3222 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -998,6 +998,15 @@ emitFlats ct
   = do { lie_var <- getConstraintVar ;
          updTcRef lie_var (`addFlats` ct) }
 
+emitWantedCts :: Cts -> TcM () 
+-- Precondition: all wanted
+emitWantedCts = mapBagM_ emit_wanted_ct
+  where emit_wanted_ct ct 
+          | v <- cc_id ct 
+          , Wanted loc <- cc_flavor ct 
+          = emitFlat (EvVarX v loc)
+          | otherwise = panic "emitWantecCts: can't emit non-wanted!"
+
 emitImplication :: Implication -> TcM ()
 emitImplication ct
   = do { lie_var <- getConstraintVar ;
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index dc2e55ff8b..1640edc2df 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -50,12 +50,18 @@ module TcRnTypes(
 	-- Constraints
         Untouchables(..), inTouchableRange, isNoUntouchables,
 
+       -- Canonical constraints
+        Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, 
+        singleCt, extendCts, isEmptyCts, isCTyEqCan, 
+        isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
+        isCIrredEvCan, isCNonCanonical,
+        SubGoalDepth,
+
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
         andWC, addFlats, addImplics, mkFlatWC,
 
         EvVarX(..), mkEvVarX, evVarOf, evVarX, evVarOfPred,
-        WantedEvVar, wantedToFlavored,
-        keepWanted,
+        WantedEvVar,
 
         Implication(..),
         CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
@@ -67,11 +73,10 @@ module TcRnTypes(
         CtFlavor(..), pprFlavorArising, isWanted, 
         isGivenOrSolved, isGiven_maybe,
         isDerived,
-        FlavoredEvVar,
 
 	-- Pretty printing
         pprEvVarTheta, pprWantedEvVar, pprWantedsWithLocs,
-	pprEvVars, pprEvVarWithType,
+	pprEvVars, pprEvVarWithType, pprWantedEvVarWithLoc,
         pprArising, pprArisingAt,
 
 	-- Misc other types
@@ -113,6 +118,7 @@ import ListSetOps
 import FastString
 
 import Data.Set (Set)
+
 \end{code}
 
 
@@ -127,7 +133,7 @@ The monad itself has to be defined here, because it is mentioned by ErrCtxt
 
 \begin{code}
 type TcRef a 	 = IORef a
-type TcId    	 = Id 			-- Type may be a TcType  DV: WHAT??????????
+type TcId    	 = Id 			
 type TcIdSet 	 = IdSet
 
 
@@ -806,6 +812,151 @@ instance Outputable WhereFrom where
   ppr ImportBySystem     		   = ptext (sLit "{- SYSTEM -}")
 \end{code}
 
+%************************************************************************
+%*									*
+%*                       Canonical constraints                          *
+%*                                                                      *
+%*   These are the constraints the low-level simplifier works with      *
+%*									*
+%************************************************************************
+
+
+\begin{code}
+-- Types without any type functions inside.  However, note that xi
+-- types CAN contain unexpanded type synonyms; however, the
+-- (transitive) expansions of those type synonyms will not contain any
+-- type functions.
+type Xi = Type       -- In many comments, "xi" ranges over Xi
+
+type Cts = Bag Ct
+
+type SubGoalDepth = Int -- An ever increasing number used to restrict 
+                        -- simplifier iterations. Bounded by -fcontext-stack.
+
+data Ct
+  -- Atomic canonical constraints 
+  = CDictCan {  -- e.g.  Num xi
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor, 
+      cc_class  :: Class, 
+      cc_tyargs :: [Xi],
+
+      cc_depth  :: SubGoalDepth -- Simplification depth of this constraint
+                       -- See Note [WorkList]
+    }
+
+  | CIPCan {	-- ?x::tau
+      -- See note [Canonical implicit parameter constraints].
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor,
+      cc_ip_nm  :: IPName Name,
+      cc_ip_ty  :: TcTauType, -- Not a Xi! See same not as above
+      cc_depth  :: SubGoalDepth        -- See Note [WorkList]
+    }
+
+  | CIrredEvCan {  -- These stand for yet-unknown predicates
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor,
+      cc_ty     :: Xi, -- cc_ty is flat hence it may only be of the form (tv xi1 xi2 ... xin)
+                       -- Since, if it were a type constructor application, that'd make the
+                       -- whole constraint a CDictCan, CIPCan, or CTyEqCan. And it can't be
+                       -- a type family application either because it's a Xi type.
+      cc_depth :: SubGoalDepth -- See Note [WorkList]
+    }
+
+  | CTyEqCan {  -- tv ~ xi	(recall xi means function free)
+       -- Invariant: 
+       --   * tv not in tvs(xi)   (occurs check)
+       --   * 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, 
+      cc_rhs    :: Xi,
+
+      cc_depth :: SubGoalDepth -- See Note [WorkList] 
+    }
+
+  | CFunEqCan {  -- F xis ~ xi  
+                 -- Invariant: * isSynFamilyTyCon cc_fun 
+                 --            * typeKind (F xis) `compatKind` typeKind xi
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor, 
+      cc_fun    :: TyCon,	-- A type function
+      cc_tyargs :: [Xi],	-- Either under-saturated or exactly saturated
+      cc_rhs    :: Xi,      	--    *never* over-saturated (because if so
+      		      		--    we should have decomposed)
+
+      cc_depth  :: SubGoalDepth -- See Note [WorkList]
+                   
+    }
+
+  | CNonCanonical { -- See Note [NonCanonical Semantics] 
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor, 
+      cc_depth  :: SubGoalDepth
+    }
+
+
+instance Outputable Ct where
+  ppr ct = ppr (cc_flavor ct) <> braces (ppr (cc_depth ct))
+                  <+> ppr ev_var <+> dcolon <+> ppr (varType ev_var) 
+                  <+> parens (text ct_sort)
+         where ev_var  = cc_id ct
+               ct_sort = case ct of 
+                           CTyEqCan {}      -> "CTyEqCan"
+                           CFunEqCan {}     -> "CFunEqCan"
+                           CNonCanonical {} -> "CNonCanonical"
+                           CDictCan {}      -> "CDictCan"
+                           CIPCan {}        -> "CIPCan"
+                           CIrredEvCan {}   -> "CIrredEvCan"
+\end{code}
+
+\begin{code}
+singleCt :: Ct -> Cts 
+singleCt = unitBag 
+
+andCts :: Cts -> Cts -> Cts 
+andCts = unionBags
+
+extendCts :: Cts -> Ct -> Cts 
+extendCts = snocBag 
+
+andManyCts :: [Cts] -> Cts 
+andManyCts = unionManyBags
+
+emptyCts :: Cts 
+emptyCts = emptyBag
+
+isEmptyCts :: Cts -> Bool
+isEmptyCts = isEmptyBag
+
+isCTyEqCan :: Ct -> Bool 
+isCTyEqCan (CTyEqCan {})  = True 
+isCTyEqCan (CFunEqCan {}) = False
+isCTyEqCan _              = False 
+
+isCDictCan_Maybe :: Ct -> Maybe Class
+isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls
+isCDictCan_Maybe _              = Nothing
+
+isCIPCan_Maybe :: Ct -> Maybe (IPName Name)
+isCIPCan_Maybe  (CIPCan {cc_ip_nm = nm }) = Just nm
+isCIPCan_Maybe _                = Nothing
+
+isCIrredEvCan :: Ct -> Bool
+isCIrredEvCan (CIrredEvCan {}) = True
+isCIrredEvCan _                = False
+
+isCFunEqCan_Maybe :: Ct -> Maybe TyCon
+isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc
+isCFunEqCan_Maybe _ = Nothing
+
+isCNonCanonical :: Ct -> Bool
+isCNonCanonical (CNonCanonical {}) = True 
+isCNonCanonical _ = False 
+\end{code}
 
 %************************************************************************
 %*									*
@@ -819,10 +970,11 @@ instance Outputable WhereFrom where
 v%************************************************************************
 
 \begin{code}
+
 data WantedConstraints
-  = WC { wc_flat  :: Bag WantedEvVar   -- Unsolved constraints, all wanted
+  = WC { wc_flat  :: Cts                -- Unsolved constraints, all wanted
        , wc_impl  :: Bag Implication
-       , wc_insol :: Bag FlavoredEvVar -- Insoluble constraints, can be
+       , wc_insol :: Cts               -- Insoluble constraints, can be
                                        -- wanted, given, or derived
                                        -- See Note [Insoluble constraints]
     }
@@ -830,8 +982,9 @@ data WantedConstraints
 emptyWC :: WantedConstraints
 emptyWC = WC { wc_flat = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag }
 
-mkFlatWC :: Bag WantedEvVar -> WantedConstraints
-mkFlatWC wevs = WC { wc_flat = wevs, wc_impl = emptyBag, wc_insol = emptyBag }
+mkFlatWC :: [Ct] -> WantedConstraints
+mkFlatWC cts 
+  = WC { wc_flat = listToBag cts, wc_impl = emptyBag, wc_insol = emptyBag }
 
 isEmptyWC :: WantedConstraints -> Bool
 isEmptyWC (WC { wc_flat = f, wc_impl = i, wc_insol = n })
@@ -850,7 +1003,11 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 })
        , wc_insol = n1 `unionBags` n2 }
 
 addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints
-addFlats wc wevs = wc { wc_flat = wc_flat wc `unionBags` wevs }
+addFlats wc wevs 
+  = wc { wc_flat = wc_flat wc `unionBags` cts }
+  where cts = mapBag mk_noncan wevs 
+        mk_noncan (EvVarX v wl) 
+          = CNonCanonical { cc_id = v, cc_flavor = Wanted wl, cc_depth = 0}
 
 addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints
 addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic }
@@ -859,7 +1016,7 @@ instance Outputable WantedConstraints where
   ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n})
    = ptext (sLit "WC") <+> braces (vcat
         [ if isEmptyBag f then empty else
-          ptext (sLit "wc_flat =")  <+> pprBag pprWantedEvVar f
+          ptext (sLit "wc_flat =")  <+> pprBag ppr f
         , if isEmptyBag i then empty else
           ptext (sLit "wc_impl =")  <+> pprBag ppr i
         , if isEmptyBag n then empty else
@@ -995,7 +1152,7 @@ data EvVarX a = EvVarX EvVar a
      -- An evidence variable with accompanying info
 
 type WantedEvVar   = EvVarX WantedLoc     -- The location where it arose
-type FlavoredEvVar = EvVarX CtFlavor
+
 
 instance Outputable (EvVarX a) where
   ppr (EvVarX ev _) = pprEvVarWithType ev
@@ -1014,17 +1171,6 @@ evVarX (EvVarX _ a) = a
 evVarOfPred :: EvVarX a -> PredType
 evVarOfPred wev = evVarPred (evVarOf wev)
 
-wantedToFlavored :: WantedEvVar -> FlavoredEvVar
-wantedToFlavored (EvVarX v wl) = EvVarX v (Wanted wl)
-
-keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar
-keepWanted flevs
-  = foldrBag keep_wanted emptyBag flevs
-    -- Important: use fold*r*Bag to preserve the order of the evidence variables.
-  where
-    keep_wanted :: FlavoredEvVar -> Bag WantedEvVar -> Bag WantedEvVar
-    keep_wanted (EvVarX ev (Wanted wloc)) r = consBag (EvVarX ev wloc) r
-    keep_wanted _                         r = r
 \end{code}
 
 
@@ -1040,7 +1186,7 @@ pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v)
 
 pprWantedsWithLocs :: WantedConstraints -> SDoc
 pprWantedsWithLocs wcs
-  =  vcat [ pprBag pprWantedEvVarWithLoc (wc_flat wcs)
+  =  vcat [ pprBag ppr (wc_flat wcs)
           , pprBag ppr (wc_impl wcs)
           , pprBag ppr (wc_insol wcs) ]
 
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 553d4613c6..7d3ee73f6b 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1,5 +1,5 @@
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# OPTIONS -Wwarn -fno-warn-tabs #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
 -- detab the module (please do the detabbing in a separate patch). See
@@ -9,18 +9,17 @@
 -- Type definitions for the constraint solver
 module TcSMonad ( 
 
-       -- Canonical constraints
-    CanonicalCts, emptyCCan, andCCan, andCCans, 
-    singleCCan, extendCCans, isEmptyCCan, isCTyEqCan, 
-    isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
-    isCIrredEvCan, isCFrozenErr,
+       -- Canonical constraints, definition is now in TcRnTypes
 
-    WorkList, unionWorkList, unionWorkLists, isEmptyWorkList, emptyWorkList,
-    workListFromEq, workListFromNonEq,
-    workListFromEqs, workListFromNonEqs, foldrWorkListM,
+    WorkList(..), isEmptyWorkList, emptyWorkList,
+    workListFromEq, workListFromNonEq, workListFromCt, 
+    extendWorkListEq, extendWorkListNonEq, extendWorkListCt, 
+    appendWorkListCt, appendWorkListEqs, unionWorkList,
 
-    CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, 
-    deCanonicalise, mkFrozenError,
+    getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted,
+
+    Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts, 
+    emitFrozenError,
 
     isWanted, isGivenOrSolved, isDerived,
     isGivenOrSolvedCt, isGivenCt_maybe, 
@@ -34,14 +33,17 @@ module TcSMonad (
     getWantedLoc,
 
     TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality 
-    traceFireTcS, bumpStepCountTcS,
-    tryTcS, nestImplicTcS, recoverTcS, wrapErrTcS, wrapWarnTcS,
+    traceFireTcS, bumpStepCountTcS, doWithInert,
+    tryTcS, nestImplicTcS, recoverTcS,
+    wrapErrTcS, wrapWarnTcS,
+
     SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,
 
        -- Creation of evidence variables
-    newEvVar,
-    newDerivedId, newGivenEqVar,
-    newEqVar, newIPVar, newDictVar, newKindConstraint,
+    newEvVar, forceNewEvVar, delCachedEvVar, updateFlatCache, flushFlatCache,
+    newGivenEqVar,
+    newEqVar, newKindConstraint,
+    EvVarCreated (..), isNewEvVar, FlatEqOrigin ( .. ), origin_matches,
 
        -- Setting evidence variables 
     setEqBind,
@@ -51,14 +53,22 @@ module TcSMonad (
 
     setWantedTyBind,
 
-    lookupFlatCacheMap, updateFlatCacheMap,
-
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
-    getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
+    getTcEvBindsMap, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
+    getTcSEvVarCacheMap, getTcSEvVarFlatCache, setTcSEvVarCacheMap, pprEvVarCache,
 
     newFlattenSkolemTy,                         -- Flatten skolems 
 
+        -- Inerts 
+    InertSet(..), 
+    getInertEqs, rewriteFromInertEqs, liftInertEqsTy,
+    emptyInert, getTcSInerts, updInertSet, extractUnsolved,
+    extractUnsolvedTcS, modifyInertTcS,
+    updInertSetTcS, partitionCCanMap, partitionEqMap,
+    getRelevantCts, extractRelevantInerts,
+    CCanMap (..), CtTypeMap, pprCtTypeMap, mkPredKeyForTypeMap, partitionCtTypeMap,
+
 
     instDFunTypes,                              -- Instantiation
     instDFunConstraints,          
@@ -75,7 +85,7 @@ 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
@@ -100,6 +110,7 @@ import {-# SOURCE #-} qualified TcUnify as TcM ( unifyKindEq, mkKindErrorCtxt )
 import Kind
 import TcType
 import DynFlags
+import Type
 
 import Coercion
 import Class
@@ -113,94 +124,28 @@ import Outputable
 import Bag
 import MonadUtils
 import VarSet
-import Pair
+
+import Pair ( pSnd )
 import FastString
-import StaticFlags
 import Util
 
 import HsBinds               -- for TcEvBinds stuff 
 import Id 
 import TcRnTypes
 
-import Control.Monad
+import Unique 
+import UniqFM
+import Maybes ( orElse )
+
+import Control.Monad( when )
+import StaticFlags( opt_PprStyle_Debug )
 import Data.IORef
-import qualified Data.Map as Map
-\end{code}
 
+import TrieMap
 
-%************************************************************************
-%*									*
-%*                       Canonical constraints                          *
-%*                                                                      *
-%*   These are the constraints the low-level simplifier works with      *
-%*									*
-%************************************************************************
+\end{code}
 
 \begin{code}
--- Types without any type functions inside.  However, note that xi
--- types CAN contain unexpanded type synonyms; however, the
--- (transitive) expansions of those type synonyms will not contain any
--- type functions.
-type Xi = Type       -- In many comments, "xi" ranges over Xi
-
-type CanonicalCts = Bag CanonicalCt
- 
-data CanonicalCt
-  -- Atomic canonical constraints 
-  = CDictCan {  -- e.g.  Num xi
-      cc_id     :: EvVar,
-      cc_flavor :: CtFlavor, 
-      cc_class  :: Class, 
-      cc_tyargs :: [Xi]
-    }
-
-  | CIPCan {	-- ?x::tau
-      -- See note [Canonical implicit parameter constraints].
-      cc_id     :: EvVar,
-      cc_flavor :: CtFlavor,
-      cc_ip_nm  :: IPName Name,
-      cc_ip_ty  :: TcTauType
-    }
-
-  | CIrredEvCan {
-      cc_id     :: EvVar,
-      cc_flavor :: CtFlavor,
-      cc_ty     :: Xi
-    }
-
-  | CTyEqCan {  -- tv ~ xi	(recall xi means function free)
-       -- Invariant: 
-       --   * tv not in tvs(xi)   (occurs check)
-       --   * 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, 
-      cc_rhs    :: Xi
-    }
-
-  | CFunEqCan {  -- F xis ~ xi  
-                 -- Invariant: * isSynFamilyTyCon cc_fun 
-                 --            * typeKind (F xis) `compatKind` typeKind xi
-      cc_id     :: EvVar,
-      cc_flavor :: CtFlavor, 
-      cc_fun    :: TyCon,	-- A type function
-      cc_tyargs :: [Xi],	-- Either under-saturated or exactly saturated
-      cc_rhs    :: Xi      	--    *never* over-saturated (because if so
-      		      		--    we should have decomposed)
-                   
-    }
-
-  | 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 
 
@@ -221,148 +166,443 @@ unifyKindTcS ty1 ty2 ki1 ki2
       return (maybe False (const True) mb_r)
   where ctxt = TcM.mkKindErrorCtxt ty1 ki1 ty2 ki2
 
-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 (CIrredEvCan { cc_ty = ty })                 = tyVarsOfType ty
-tyVarsOfCanonical (CFrozenErr { cc_id = ev })                  = tyVarsOfEvVar ev
-
-tyVarsOfCDict :: CanonicalCt -> TcTyVarSet 
-tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
-tyVarsOfCDict _ct                            = emptyVarSet 
-
-tyVarsOfCDicts :: CanonicalCts -> TcTyVarSet 
-tyVarsOfCDicts = foldrBag (unionVarSet . tyVarsOfCDict) emptyVarSet
-
-tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet
-tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet
-
-instance Outputable CanonicalCt where
-  ppr (CDictCan d fl cls tys)     
-      = ppr fl <+> ppr d  <+> dcolon <+> pprClassPred cls tys
-  ppr (CIPCan ip fl ip_nm ty)     
-      = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
-  ppr (CIrredEvCan v fl ty)
-      = ppr fl <+> ppr v <+> dcolon <+> ppr ty
-  ppr (CTyEqCan co fl 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 (Pair (mkTyConApp tc tys) ty)
-  ppr (CFrozenErr co fl)
-      = ppr fl <+> pprEvVarWithType co
 \end{code}
 
-Note [Canonical implicit parameter constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The type in a canonical implicit parameter constraint doesn't need to
-be a xi (type-function-free type) since we can defer the flattening
-until checking this type for equality with another type.  If we
-encounter two IP constraints with the same name, they MUST have the
-same type, and at that point we can generate a flattened equality
-constraint between the types.  (On the other hand, the types in two
-class constraints for the same class MAY be equal, so they need to be
-flattened in the first place to facilitate comparing them.)
-
-\begin{code}
-singleCCan :: CanonicalCt -> CanonicalCts 
-singleCCan = unitBag 
+%************************************************************************
+%*									*
+%*                            Worklists                                *
+%*  Canonical and non-canonical constraints that the simplifier has to  *
+%*  work on. Including their simplification depths.                     *
+%*                                                                      *
+%*									*
+%************************************************************************
 
-andCCan :: CanonicalCts -> CanonicalCts -> CanonicalCts 
-andCCan = unionBags
+Note [WorkList]
+~~~~~~~~~~~~~~~
 
-extendCCans :: CanonicalCts -> CanonicalCt -> CanonicalCts 
-extendCCans = snocBag 
+A WorkList contains canonical and non-canonical items (of all flavors). 
+Notice that each Ct now has a simplification depth. We may 
+consider using this depth for prioritization as well in the future. 
 
-andCCans :: [CanonicalCts] -> CanonicalCts 
-andCCans = unionManyBags
+As a simple form of priority queue, our worklist separates out
+equalities (wl_eqs) from the rest of the canonical constraints, 
+so that it's easier to deal with them first, but the separation 
+is not strictly necessary. Notice that non-canonical constraints 
+are also parts of the worklist. 
 
-emptyCCan :: CanonicalCts 
-emptyCCan = emptyBag
+Note [NonCanonical Semantics]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note that canonical constraints involve a CNonCanonical constructor. In the worklist
+we use this constructor for constraints that have not yet been canonicalized such as 
+   [Int] ~ [a] 
+In other words, all constraints start life as NonCanonicals. 
 
-isEmptyCCan :: CanonicalCts -> Bool
-isEmptyCCan = isEmptyBag
+On the other hand, in the Inert Set (see below) the presence of a NonCanonical somewhere
+means that we have a ``frozen error''. 
 
-isCTyEqCan :: CanonicalCt -> Bool 
-isCTyEqCan (CTyEqCan {})  = True 
-isCTyEqCan (CFunEqCan {}) = False
-isCTyEqCan _              = False 
+NonCanonical constraints never interact directly with other constraints -- but they can
+be rewritten by equalities (for instance if a non canonical exists in the inert, we'd 
+better rewrite it as much as possible before reporting it as an error to the user)
 
-isCDictCan_Maybe :: CanonicalCt -> Maybe Class
-isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls
-isCDictCan_Maybe _              = Nothing
+\begin{code}
 
-isCIPCan_Maybe :: CanonicalCt -> Maybe (IPName Name)
-isCIPCan_Maybe  (CIPCan {cc_ip_nm = nm }) = Just nm
-isCIPCan_Maybe _                = Nothing
+-- See Note [WorkList]
+data WorkList = WorkList { wl_eqs  :: [Ct], wl_rest :: [Ct] }
 
-isCIrredEvCan :: CanonicalCt -> Bool
-isCIrredEvCan (CIrredEvCan {}) = True
-isCIrredEvCan _                = False
 
-isCFunEqCan_Maybe :: CanonicalCt -> Maybe TyCon
-isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc
-isCFunEqCan_Maybe _ = Nothing
+unionWorkList :: WorkList -> WorkList -> WorkList
+unionWorkList new_wl orig_wl = 
+   WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl
+            , wl_rest = wl_rest new_wl ++ wl_rest orig_wl }
 
-isCFrozenErr :: CanonicalCt -> Bool
-isCFrozenErr (CFrozenErr {}) = True
-isCFrozenErr _               = False
+extendWorkListEq :: Ct -> WorkList -> WorkList
+-- Extension by equality
+extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
 
+extendWorkListNonEq :: Ct -> WorkList -> WorkList
+-- Extension by non equality
+extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
 
--- 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 }
+extendWorkListCt :: Ct -> WorkList -> WorkList
+-- Agnostic
+extendWorkListCt ct wl
+ | isLCoVar (cc_id ct) = extendWorkListEq ct wl
+ | otherwise = extendWorkListNonEq ct wl
 
-unionWorkList :: WorkList -> WorkList -> WorkList
-unionWorkList wl1 wl2
-  = WorkList { weqs = weqs wl1 `andCCan` weqs wl2
-             , wrest = wrest wl1 `andCCan` wrest wl2 }
+appendWorkListCt :: [Ct] -> WorkList -> WorkList
+-- Agnostic
+appendWorkListCt cts wl = foldr extendWorkListCt wl cts
 
-unionWorkLists :: [WorkList] -> WorkList 
-unionWorkLists = foldr unionWorkList emptyWorkList
+appendWorkListEqs :: [Ct] -> WorkList -> WorkList
+-- Append a list of equalities
+appendWorkListEqs cts wl = foldr extendWorkListEq wl cts
 
 isEmptyWorkList :: WorkList -> Bool
-isEmptyWorkList wl = isEmptyCCan (weqs wl) && isEmptyCCan (wrest wl)
+isEmptyWorkList wl = null (wl_eqs wl) &&  null (wl_rest wl)
 
 emptyWorkList :: WorkList
-emptyWorkList
-  = WorkList { weqs = emptyBag, wrest = emptyBag }
+emptyWorkList = WorkList { wl_eqs  = [], wl_rest = [] }
 
-workListFromEq :: CanonicalCt -> WorkList
-workListFromEq = workListFromEqs . singleCCan
+workListFromEq :: Ct -> WorkList
+workListFromEq ct = WorkList { wl_eqs = [ct], wl_rest = [] }
 
-workListFromNonEq :: CanonicalCt -> WorkList
-workListFromNonEq = workListFromNonEqs . singleCCan 
+workListFromNonEq :: Ct -> WorkList
+workListFromNonEq ct = WorkList { wl_eqs = [], wl_rest = [ct] }
 
-workListFromNonEqs :: CanonicalCts -> WorkList
-workListFromNonEqs cts
-  = WorkList { weqs = emptyCCan, wrest = cts }
+workListFromCt :: Ct -> WorkList
+-- Agnostic 
+workListFromCt ct | isLCoVar (cc_id ct) = workListFromEq ct 
+                  | otherwise           = workListFromNonEq ct
 
-workListFromEqs :: CanonicalCts -> WorkList
-workListFromEqs cts
-  = WorkList { weqs = cts, wrest = emptyCCan }
+-- Pretty printing 
+instance Outputable WorkList where 
+  ppr wl = vcat [ text "WorkList (eqs)   = " <+> ppr (wl_eqs wl)
+                , text "WorkList (rest)  = " <+> ppr (wl_rest wl)
+                ]
 
-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 }
+keepWanted :: Cts -> Cts
+keepWanted = filterBag isWantedCt
+    -- DV: there used to be a note here that read: 
+    -- ``Important: use fold*r*Bag to preserve the order of the evidence variables'' 
+    -- DV: Is this still relevant? 
 
-instance Outputable WorkList where 
-  ppr wl = vcat [ text "WorkList (Equalities) = " <+> ppr (weqs wl)
-                , text "WorkList (Other)      = " <+> ppr (wrest wl) ]
+\end{code}
+
+%************************************************************************
+%*									*
+%*                            Inert sets                                *
+%*                                                                      *
+%*									*
+%************************************************************************
+
+
+Note [InertSet invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An InertSet is a bag of canonical constraints, with the following invariants:
+
+  1 No two constraints react with each other. 
+    
+    A tricky case is when there exists a given (solved) dictionary 
+    constraint and a wanted identical constraint in the inert set, but do 
+    not react because reaction would create loopy dictionary evidence for 
+    the wanted. See note [Recursive dictionaries]
 
+  2 Given equalities form an idempotent substitution [none of the
+    given LHS's occur in any of the given RHS's or reactant parts]
+
+  3 Wanted equalities also form an idempotent substitution
+
+  4 The entire set of equalities is acyclic.
+
+  5 Wanted dictionaries are inert with the top-level axiom set 
+
+  6 Equalities of the form tv1 ~ tv2 always have a touchable variable
+    on the left (if possible).
+
+  7 No wanted constraints tv1 ~ tv2 with tv1 touchable. Such constraints
+    will be marked as solved right before being pushed into the inert set. 
+    See note [Touchables and givens].
+
+  8 No Given constraint mentions a touchable unification variable, but 
+    Given/Solved may do so. 
+
+  9 Given constraints will also have their superclasses in the inert set, 
+    but Given/Solved will not. 
+ 
+Note that 6 and 7 are /not/ enforced by canonicalization but rather by 
+insertion in the inert list, ie by TcInteract. 
+
+During the process of solving, the inert set will contain some
+previously given constraints, some wanted constraints, and some given
+constraints which have arisen from solving wanted constraints. For
+now we do not distinguish between given and solved constraints.
+
+Note that we must switch wanted inert items to given when going under an
+implication constraint (when in top-level inference mode).
+
+\begin{code}
+
+data CCanMap a = CCanMap { cts_given   :: UniqFM Cts
+                                          -- Invariant: all Given
+                         , cts_derived :: UniqFM Cts 
+                                          -- Invariant: all Derived
+                         , cts_wanted  :: UniqFM Cts } 
+                                          -- Invariant: all Wanted
+
+cCanMapToBag :: CCanMap a -> Cts 
+cCanMapToBag cmap = foldUFM unionBags rest_wder (cts_given cmap)
+  where rest_wder = foldUFM unionBags rest_der  (cts_wanted cmap) 
+        rest_der  = foldUFM unionBags emptyCts  (cts_derived cmap)
+
+emptyCCanMap :: CCanMap a 
+emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wanted = emptyUFM } 
+
+updCCanMap:: Uniquable a => (a,Ct) -> CCanMap a -> CCanMap a 
+updCCanMap (a,ct) cmap 
+  = case cc_flavor ct of 
+      Wanted {}  -> cmap { cts_wanted  = insert_into (cts_wanted cmap)  } 
+      Given {}   -> cmap { cts_given   = insert_into (cts_given cmap)   }
+      Derived {} -> cmap { cts_derived = insert_into (cts_derived cmap) }
+  where 
+    insert_into m = addToUFM_C unionBags m a (singleCt ct)
+
+getRelevantCts :: Uniquable a => a -> CCanMap a -> (Cts, CCanMap a) 
+-- Gets the relevant constraints and returns the rest of the CCanMap
+getRelevantCts a cmap 
+    = let relevant = lookup (cts_wanted cmap) `unionBags`
+                     lookup (cts_given cmap)  `unionBags`
+                     lookup (cts_derived cmap) 
+          residual_map = cmap { cts_wanted  = delFromUFM (cts_wanted cmap) a
+                              , cts_given   = delFromUFM (cts_given cmap) a
+                              , cts_derived = delFromUFM (cts_derived cmap) a }
+      in (relevant, residual_map) 
+  where
+    lookup map = lookupUFM map a `orElse` emptyCts
+
+
+getCtTypeMapRelevants :: PredType -> TypeMap Ct -> (Cts, TypeMap Ct)
+getCtTypeMapRelevants key_pty tmap
+  = partitionCtTypeMap (\ct -> mkPredKeyForTypeMap ct `eqType` key_pty) tmap
+
+
+partitionCCanMap :: (Ct -> Bool) -> CCanMap a -> (Cts,CCanMap a) 
+-- All constraints that /match/ the predicate go in the bag, the rest remain in the map
+partitionCCanMap pred cmap
+  = let (ws_map,ws) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_wanted cmap) 
+        (ds_map,ds) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_derived cmap)
+        (gs_map,gs) = foldUFM_Directly aux (emptyUFM,emptyCts) (cts_given cmap) 
+    in (ws `andCts` ds `andCts` gs, cmap { cts_wanted  = ws_map
+                                         , cts_given   = gs_map
+                                         , cts_derived = ds_map }) 
+  where aux k this_cts (mp,acc_cts) = (new_mp, new_acc_cts)
+                                    where new_mp      = addToUFM mp k cts_keep
+                                          new_acc_cts = acc_cts `andCts` cts_out
+                                          (cts_out, cts_keep) = partitionBag pred this_cts
+
+partitionEqMap :: (Ct -> Bool) -> TyVarEnv (Ct,Coercion) -> ([Ct], TyVarEnv (Ct,Coercion))
+partitionEqMap pred isubst 
+  = let eqs_out = foldVarEnv extend_if_pred [] isubst
+        eqs_in  = filterVarEnv_Directly (\_ (ct,_) -> not (pred ct)) isubst
+    in (eqs_out, eqs_in)
+  where extend_if_pred (ct,_) cts = if pred ct then ct : cts else cts
+
+
+extractUnsolvedCMap :: CCanMap a -> (Cts, CCanMap a)
+-- Gets the wanted or derived constraints and returns a residual
+-- CCanMap with only givens.
+extractUnsolvedCMap cmap =
+  let wntd = foldUFM unionBags emptyCts (cts_wanted cmap)
+      derd = foldUFM unionBags emptyCts (cts_derived cmap)
+  in (wntd `unionBags` derd, 
+      cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM })
+
+-- See Note [InertSet invariants]
+data InertSet 
+  = IS { inert_eqs     :: TyVarEnv (Ct,Coercion) 
+         -- Must all be CTyEqCans! If an entry exists of the form: 
+         --   a |-> ct,co
+         -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } 
+         -- And  co : a ~ xi
+       , inert_eq_tvs  :: InScopeSet -- Invariant: superset of inert_eqs tvs
+
+       , inert_dicts        :: CCanMap Class -- Dictionaries only, index is the class
+       , inert_ips          :: CCanMap (IPName Name)      -- Implicit parameters 
+         -- NB: We do not want to use TypeMaps here because functional dependencies
+         -- will only match on the class but not the type. Similarly IPs match on the
+         -- name but not on the whole datatype
+
+       , inert_funeqs       :: CtTypeMap -- Map from family heads to CFunEqCan constraints
+
+       , inert_irreds       :: Cts  -- Irreducible predicates
+       , inert_frozen       :: Cts  -- All non-canonicals are kept here (as frozen errors)
+       }
+
+
+type CtTypeMap = TypeMap Ct
+
+pprCtTypeMap :: TypeMap Ct -> SDoc 
+pprCtTypeMap ctmap = ppr (foldTM (:) ctmap [])
+
+ctTypeMapCts :: TypeMap Ct -> Cts
+ctTypeMapCts ctmap = foldTM (\ct cts -> extendCts cts ct) ctmap emptyCts
+
+mkPredKeyForTypeMap :: Ct -> PredType
+-- Create a key from a constraint to use in the inert CtTypeMap.
+-- The only interesting case is for family applications, where the 
+-- key is not the whole PredType of cc_id, but rather the family 
+-- equality left hand side (head)
+mkPredKeyForTypeMap (CFunEqCan { cc_fun = fn, cc_tyargs = xis }) 
+  = mkTyConApp fn xis
+mkPredKeyForTypeMap ct 
+  = evVarPred (cc_id ct)
+
+partitionCtTypeMap :: (Ct -> Bool)
+                   -> TypeMap Ct -> (Cts, TypeMap Ct)
+-- Kick out the ones that match the predicate and keep the rest in the typemap
+partitionCtTypeMap f ctmap
+  = foldTM upd_acc ctmap (emptyBag,ctmap)
+  where upd_acc ct (cts,acc_map)
+         | f ct      = (extendCts cts ct, alterTM ct_key (\_ -> Nothing) acc_map)
+         | otherwise = (cts,acc_map)
+         where ct_key = mkPredKeyForTypeMap ct
+
+
+instance Outputable InertSet where
+  ppr is = vcat [ vcat (map ppr (varEnvElts (inert_eqs is)))
+                , vcat (map ppr (Bag.bagToList $ inert_irreds is)) 
+                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is)))
+                , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is))) 
+                , vcat (map ppr (Bag.bagToList $ ctTypeMapCts (inert_funeqs is)))
+                , text "Frozen errors =" <+> -- Clearly print frozen errors
+                    braces (vcat (map ppr (Bag.bagToList $ inert_frozen is)))
+                , text "Warning: Not displaying cached (solved) constraints"
+                ]
+                       
+emptyInert :: InertSet
+emptyInert = IS { inert_eqs     = emptyVarEnv
+                , inert_eq_tvs  = emptyInScopeSet
+                , inert_frozen  = emptyCts
+                , inert_irreds  = emptyCts
+                , inert_dicts   = emptyCCanMap
+                , inert_ips     = emptyCCanMap
+                , inert_funeqs  = emptyTM
+                }
+
+
+type AtomicInert = Ct 
+
+updInertSet :: InertSet -> AtomicInert -> InertSet 
+-- Add a new inert element to the inert set. 
+updInertSet is item 
+  | isCTyEqCan item                     
+  = let upd_err a b = pprPanic "updInertSet" $ 
+                      vcat [text "Multiple inert equalities:", ppr a, ppr b]
+        eqs'     = extendVarEnv_C upd_err (inert_eqs is)
+                                          (cc_tyvar item)
+                                          (item, mkEqVarLCo (cc_id item))
+        inscope' = extendInScopeSetSet (inert_eq_tvs is) (tyVarsOfCt item)
+    in is { inert_eqs = eqs', inert_eq_tvs = inscope' }
+
+{-
+       -- /Solved/ non-equalities go to the solved map
+  | Just GivenSolved <- isGiven_maybe (cc_flavor item)
+  = let pty = mkPredKeyForTypeMap item
+        solved_orig = inert_solved is
+    in is { inert_solved = alterTM pty (\_ -> Just item) solved_orig }
+-}
+
+  | Just x  <- isCIPCan_Maybe item      -- IP 
+  = is { inert_ips   = updCCanMap (x,item) (inert_ips is) }  
+  | isCIrredEvCan item                  -- Presently-irreducible evidence
+  = is { inert_irreds = inert_irreds is `Bag.snocBag` item }
+
+
+  | Just cls <- isCDictCan_Maybe item   -- Dictionary 
+  = is { inert_dicts = updCCanMap (cls,item) (inert_dicts is) }
+
+  | Just _tc <- isCFunEqCan_Maybe item  -- Function equality
+  = let pty = mkPredKeyForTypeMap item
+        upd_funeqs Nothing = Just item
+        upd_funeqs (Just _alredy_there) = panic "updInertSet: item already there!"
+    in is { inert_funeqs = alterTM pty upd_funeqs (inert_funeqs is) }
+     
+  | otherwise 
+  = is { inert_frozen = inert_frozen is `Bag.snocBag` item }
+
+updInertSetTcS :: AtomicInert -> TcS ()
+-- Add a new item in the inerts of the monad
+updInertSetTcS item
+  = do { traceTcS "updInertSetTcs {" $ 
+         text "Trying to insert new inert item:" <+> ppr item
+
+       ; modifyInertTcS (\is -> ((), updInertSet is item)) 
+                        
+       ; traceTcS "updInertSetTcs }" $ empty }
+
+
+modifyInertTcS :: (InertSet -> (a,InertSet)) -> TcS a 
+-- Modify the inert set with the supplied function
+modifyInertTcS upd 
+  = do { is_var <- getTcSInertsRef
+       ; curr_inert <- wrapTcS (TcM.readTcRef is_var)
+       ; let (a, new_inert) = upd curr_inert
+       ; wrapTcS (TcM.writeTcRef is_var new_inert)
+       ; return a }
+
+extractUnsolvedTcS :: TcS (Cts,Cts) 
+-- Extracts frozen errors and remaining unsolved and sets the 
+-- inert set to be the remaining! 
+extractUnsolvedTcS = 
+  modifyInertTcS extractUnsolved 
+
+extractUnsolved :: InertSet -> ((Cts,Cts), InertSet)
+-- Postcondition
+-- -------------
+-- When: 
+--   ((frozen,cts),is_solved) <- extractUnsolved inert
+-- Then: 
+-- -----------------------------------------------------------------------------
+--  cts       |  The unsolved (Derived or Wanted only) residual 
+--            |  canonical constraints, that is, no CNonCanonicals.
+-- -----------|-----------------------------------------------------------------
+--  frozen    | The CNonCanonicals of the original inert (frozen errors), 
+--            | of all flavors
+-- -----------|-----------------------------------------------------------------
+--  is_solved | Whatever remains from the inert after removing the previous two. 
+-- -----------------------------------------------------------------------------
+extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds}) 
+  = let is_solved  = is { inert_eqs    = solved_eqs
+                        , inert_eq_tvs = inert_eq_tvs is
+                        , inert_dicts  = solved_dicts
+                        , inert_ips    = solved_ips
+                        , inert_irreds = solved_irreds
+                        , inert_frozen = emptyCts
+                        , inert_funeqs = solved_funeqs
+                        }
+    in ((inert_frozen is, unsolved), is_solved)
+
+  where solved_eqs = filterVarEnv_Directly (\_ (ct,_) -> isGivenOrSolvedCt ct) eqs
+        unsolved_eqs = foldVarEnv (\(ct,_co) cts -> cts `extendCts` ct) emptyCts $
+                       eqs `minusVarEnv` solved_eqs
+
+        (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenOrSolvedCt) irreds
+        (unsolved_ips, solved_ips)       = extractUnsolvedCMap (inert_ips is) 
+        (unsolved_dicts, solved_dicts)   = extractUnsolvedCMap (inert_dicts is) 
+
+        (unsolved_funeqs, solved_funeqs) = extractUnsolvedCtTypeMap (inert_funeqs is)
+
+        unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
+                   unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs
+
+extractUnsolvedCtTypeMap :: TypeMap Ct -> (Cts,TypeMap Ct)
+extractUnsolvedCtTypeMap
+  = partitionCtTypeMap (not . isGivenOrSolved . cc_flavor)
+
+
+extractRelevantInerts :: Ct -> TcS Cts
+-- Returns the constraints from the inert set that are 'relevant' to react with 
+-- this constraint. The monad is left with the 'thinner' inerts. 
+-- NB: This function contains logic specific to the constraint solver, maybe move there?
+extractRelevantInerts wi 
+  = modifyInertTcS (extract_inert_relevants wi)
+  where extract_inert_relevants (CDictCan {cc_class = cl}) is = 
+            let (cts,dict_map) = getRelevantCts cl (inert_dicts is) 
+            in (cts, is { inert_dicts = dict_map })
+        extract_inert_relevants (CFunEqCan {cc_fun = tc, cc_tyargs = xis}) is = 
+            let (cts,feqs_map)  = getCtTypeMapRelevants (mkTyConApp tc xis) (inert_funeqs is)
+            in (cts, is { inert_funeqs = feqs_map })
+        extract_inert_relevants (CIPCan { cc_ip_nm = nm } ) is = 
+            let (cts, ips_map) = getRelevantCts nm (inert_ips is) 
+            in (cts, is { inert_ips = ips_map })
+        extract_inert_relevants (CIrredEvCan { }) is = 
+            let cts = inert_irreds is 
+            in (cts, is { inert_irreds = emptyCts })
+        extract_inert_relevants _ is = (emptyCts,is)
 \end{code}
 
 
 
+
 %************************************************************************
 %*									*
                     CtFlavor
@@ -371,22 +611,22 @@ instance Outputable WorkList where
 %************************************************************************
 
 \begin{code}
-getWantedLoc :: CanonicalCt -> WantedLoc
+getWantedLoc :: Ct -> 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 -> Bool
 isWantedCt ct = isWanted (cc_flavor ct)
-isDerivedCt :: CanonicalCt -> Bool
+isDerivedCt :: Ct -> Bool
 isDerivedCt ct = isDerived (cc_flavor ct)
 
-isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
+isGivenCt_maybe :: Ct -> Maybe GivenKind
 isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
 
-isGivenOrSolvedCt :: CanonicalCt -> Bool
+isGivenOrSolvedCt :: Ct -> Bool
 isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
 
 
@@ -459,8 +699,10 @@ added.  This is initialised from the innermost implication constraint.
 \begin{code}
 data TcSEnv
   = TcSEnv { 
-      tcs_ev_binds :: EvBindsVar,
-          -- Evidence bindings
+      tcs_ev_binds    :: EvBindsVar,
+      tcs_evvar_cache :: IORef EvVarCache,
+          -- Evidence bindings and a cache from predicate types to the created evidence 
+          -- variables. The scope of the cache will be the same as the scope of tcs_ev_binds
 
       tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)),
           -- Global type bindings
@@ -472,29 +714,36 @@ data TcSEnv
       tcs_ic_depth   :: Int,       -- Implication nesting depth
       tcs_count      :: IORef Int, -- Global step count
 
-      tcs_flat_map   :: IORef FlatCache
-    }
-
-data FlatCache 
-  = FlatCache { givenFlatCache  :: Map.Map FunEqHead (TcType,EqVar,CtFlavor)
-                -- Invariant: all CtFlavors here satisfy isGiven
-              , wantedFlatCache :: Map.Map FunEqHead (TcType,EqVar,CtFlavor) }
-                -- Invariant: all CtFlavors here satisfy isWanted
+      tcs_inerts   :: IORef InertSet, -- Current inert set
+      tcs_worklist :: IORef WorkList  -- Current worklist
 
-emptyFlatCache :: FlatCache
-emptyFlatCache 
- = FlatCache { givenFlatCache  = Map.empty, wantedFlatCache = Map.empty }
 
-newtype FunEqHead = FunEqHead (TyCon,[Xi])
+    -- TcSEnv invariant: the tcs_evvar_cache is a superset of tcs_inerts, tcs_worklist, tcs_ev_binds which must 
+    --                   all be disjoint with each other.
+    }
 
-instance Eq FunEqHead where
-  FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
+data EvVarCache
+  = EvVarCache { evc_cache     :: TypeMap (EvVar,CtFlavor)    
+                     -- Map from PredTys to Evidence variables
+                     -- used to avoid creating new goals
+               , evc_flat_cache :: TypeMap (Coercion,(Xi,CtFlavor,FlatEqOrigin))
+                     -- Map from family-free heads (F xi) to family-free types.
+                     -- Useful during flattening to share flatten skolem generation
+                     -- The boolean flag:
+                     --   True  <-> This equation was generated originally during flattening
+                     --   False <-> This equation was generated by having solved a goal
+               }
+
+data FlatEqOrigin = WhileFlattening  -- Was it generated during flattening?
+                  | WhenSolved       -- Was it generated when a family equation was solved?
+                  | Any
+
+origin_matches :: FlatEqOrigin -> FlatEqOrigin -> Bool
+origin_matches Any _                           = True
+origin_matches WhenSolved WhenSolved           = True
+origin_matches WhileFlattening WhileFlattening = True
+origin_matches _ _ = False
 
-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, 
@@ -566,14 +815,14 @@ failTcS      = wrapTcS . TcM.failWith
 panicTcS doc = pprPanic "TcCanonical" doc
 
 traceTcS :: String -> SDoc -> TcS ()
-traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc
+traceTcS herald doc = wrapTcS (TcM.traceTc 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 ()
+traceFireTcS :: SubGoalDepth -> SDoc -> TcS ()
 -- Dump a rule-firing trace
 traceFireTcS depth doc 
   = TcS $ \env -> 
@@ -586,21 +835,29 @@ traceFireTcS depth doc
 
 runTcS :: SimplContext
        -> Untouchables 	       -- Untouchables
+       -> InertSet             -- Initial inert set
+       -> WorkList             -- Initial work list
        -> TcS a		       -- What to run
        -> TcM (a, Bag EvBind)
-runTcS context untouch tcs 
+runTcS context untouch is wl tcs 
   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
+       ; ev_cache_var <- TcM.newTcRef $ 
+                         EvVarCache { evc_cache = emptyTM, evc_flat_cache = emptyTM }
        ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
        ; step_count <- TcM.newTcRef 0
-       ; flat_cache_var <- TcM.newTcRef emptyFlatCache
+
+       ; inert_var <- TcM.newTcRef is 
+       ; wl_var <- TcM.newTcRef wl
+
        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
+                          , tcs_evvar_cache = ev_cache_var
                           , tcs_ty_binds = ty_binds_var
                           , 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
-                          }
+                          , tcs_inerts   = inert_var
+                          , tcs_worklist = wl_var }
 
 	     -- Run the computation
        ; res <- unTcS tcs env
@@ -620,37 +877,53 @@ runTcS context untouch tcs
   where
     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
 
-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
-                   } ->
+
+doWithInert :: InertSet -> TcS a -> TcS a 
+doWithInert inert (TcS action)
+  = TcS $ \env -> do { new_inert_var <- TcM.newTcRef inert
+                     ; orig_cache_var <- TcM.readTcRef (tcs_evvar_cache env)
+                     ; new_cache_var <- TcM.newTcRef orig_cache_var
+                     ; action (env { tcs_inerts = new_inert_var 
+                                   , tcs_evvar_cache = new_cache_var }) }
+
+
+nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a 
+nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) 
+  = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds
+                   , tcs_evvar_cache = orig_evvar_cache_var
+                   , tcs_untch = (_outer_range, outer_tcs)
+                   , tcs_count = count
+                   , tcs_ic_depth = idepth
+                   , tcs_context = ctxt
+                   , tcs_inerts = inert_var
+                   , tcs_worklist = wl_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 }
+         -- Inherit the inerts from the outer scope
+       ; orig_inerts <- TcM.readTcRef inert_var
+       ; new_inert_var <- TcM.newTcRef orig_inerts
+                          
+         -- Inherit EvVar cache
+       ; orig_evvar_cache <- TcM.readTcRef orig_evvar_cache_var
+       ; evvar_cache <- TcM.newTcRef orig_evvar_cache
+ 
+       ; let nest_env = TcSEnv { tcs_ev_binds    = ref
+                               , tcs_evvar_cache = evvar_cache
+                               , tcs_ty_binds    = ty_binds
+                               , tcs_untch       = inner_untch
+                               , tcs_count       = count
+                               , tcs_ic_depth    = idepth+1
+                               , tcs_context     = ctxtUnderImplic ctxt 
+                               , tcs_inerts      = new_inert_var
+                               , tcs_worklist    = wl_var 
+                               -- NB: worklist is going to be empty anyway, 
+                               -- so reuse the same ref cell
+                               }
+       ; thing_inside nest_env } 
 
 recoverTcS :: TcS a -> TcS a -> TcS a
 recoverTcS (TcS recovery_code) (TcS thing_inside)
@@ -664,20 +937,68 @@ ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule")
 ctxtUnderImplic ctxt              = ctxt
 
 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!
+-- Like runTcS, but from within the TcS monad 
+-- Completely afresh inerts and worklist, be careful! 
+-- Moreover, we will simply throw away all the evidence generated. 
 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
-                                     , tcs_flat_map = flat_cache_var }
-                   ; unTcS tcs env1 })
-
--- Update TcEvBinds 
+  = TcS (\env -> 
+             do { wl_var <- TcM.newTcRef emptyWorkList
+                ; is_var <- TcM.newTcRef emptyInert
+
+                ; ty_binds_var <- TcM.newTcRef emptyVarEnv
+                ; ev_binds_var <- TcM.newTcEvBinds
+
+                ; ev_binds_cache_var <- TcM.newTcRef (EvVarCache emptyTM emptyTM)
+                    -- Empty cache: Don't inherit cache from above, see 
+                    -- Note [tryTcS for defaulting] in TcSimplify
+
+                ; let env1 = env { tcs_ev_binds = ev_binds_var
+                                 , tcs_evvar_cache = ev_binds_cache_var
+                                 , tcs_ty_binds = ty_binds_var
+                                 , tcs_inerts   = is_var
+                                 , tcs_worklist = wl_var } 
+                ; unTcS tcs env1 })
+
+-- Getters and setters of TcEnv fields
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
+-- Getter of inerts and worklist
+getTcSInertsRef :: TcS (IORef InertSet)
+getTcSInertsRef = TcS (return . tcs_inerts)
+
+getTcSWorkListRef :: TcS (IORef WorkList) 
+getTcSWorkListRef = TcS (return . tcs_worklist) 
+
+getTcSInerts :: TcS InertSet 
+getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) 
+
+getTcSWorkList :: TcS WorkList
+getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef) 
+
+updWorkListTcS :: (WorkList -> WorkList) -> TcS () 
+updWorkListTcS f 
+  = updWorkListTcS_return (\w -> ((),f w))
+
+updWorkListTcS_return :: (WorkList -> (a,WorkList)) -> TcS a
+updWorkListTcS_return f
+  = do { wl_var <- getTcSWorkListRef
+       ; wl_curr <- wrapTcS (TcM.readTcRef wl_var)
+       ; let (res,new_work) = f wl_curr
+       ; wrapTcS (TcM.writeTcRef wl_var new_work)
+       ; return res }
+
+emitFrozenError :: CtFlavor -> EvVar -> SubGoalDepth -> TcS ()
+-- Emits a non-canonical constraint that will stand for a frozen error in the inerts. 
+emitFrozenError fl ev depth 
+  = do { traceTcS "Emit frozen error" (ppr ev <+> dcolon <+> ppr (evVarPred ev))
+       ; inert_ref <- getTcSInertsRef 
+       ; inerts <- wrapTcS (TcM.readTcRef inert_ref)
+       ; let ct = CNonCanonical { cc_id = ev
+                                , cc_flavor = fl
+                                , cc_depth = depth } 
+             inerts_new = inerts { inert_frozen = extendCts (inert_frozen inerts) ct } 
+       ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) }
+
 getDynFlags :: TcS DynFlags
 getDynFlags = wrapTcS TcM.getDOpts
 
@@ -687,6 +1008,32 @@ getTcSContext = TcS (return . tcs_context)
 getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds) 
 
+getTcSEvVarCache :: TcS (IORef EvVarCache)
+getTcSEvVarCache = TcS (return . tcs_evvar_cache)
+
+flushFlatCache :: TcS ()
+flushFlatCache
+  = do { cache_var <- getTcSEvVarCache
+       ; the_cache <- wrapTcS $ TcM.readTcRef cache_var
+       ; wrapTcS $ TcM.writeTcRef cache_var (the_cache { evc_flat_cache = emptyTM }) }
+
+
+getTcSEvVarCacheMap :: TcS (TypeMap (EvVar,CtFlavor))
+getTcSEvVarCacheMap = do { cache_var <- getTcSEvVarCache 
+                         ; the_cache <- wrapTcS $ TcM.readTcRef cache_var 
+                         ; return (evc_cache the_cache) }
+
+getTcSEvVarFlatCache :: TcS (TypeMap (Coercion,(Type,CtFlavor,FlatEqOrigin)))
+getTcSEvVarFlatCache = do { cache_var <- getTcSEvVarCache 
+                          ; the_cache <- wrapTcS $ TcM.readTcRef cache_var 
+                          ; return (evc_flat_cache the_cache) }
+
+setTcSEvVarCacheMap :: TypeMap (EvVar,CtFlavor) -> TcS () 
+setTcSEvVarCacheMap cache = do { cache_var <- getTcSEvVarCache 
+                               ; orig_cache <- wrapTcS $ TcM.readTcRef cache_var
+                               ; let new_cache = orig_cache { evc_cache = cache } 
+                               ; wrapTcS $ TcM.writeTcRef cache_var new_cache }
+
 getUntouchables :: TcS TcsUntouchables
 getUntouchables = TcS (return . tcs_untch)
 
@@ -696,50 +1043,13 @@ getTcSTyBinds = TcS (return . tcs_ty_binds)
 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,EqVar,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 -> EqVar -> TcS ()
-updateFlatCacheMap _tc _xis _tv (Derived {}) _eqv
-  = return () -- Not caching deriveds
-updateFlatCacheMap tc xis ty fl eqv
-  = 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,eqv,fl) $
-                                             givenFlatCache cache_map }
-              | isWanted fl
-              = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,eqv,fl) $
-                                              wantedFlatCache cache_map }
-              | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty
-       ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map }
-
-
-getTcEvBindsBag :: TcS EvBindMap
-getTcEvBindsBag
+
+getTcEvBindsMap :: TcS EvBindMap
+getTcEvBindsMap
   = do { EvBindsVar ev_ref _ <- getTcEvBinds 
        ; wrapTcS $ TcM.readTcRef ev_ref }
 
+
 setEqBind :: EqVar -> LCoercion -> TcS () 
 setEqBind eqv co = setEvBind eqv (EvCoercionBox co)
 
@@ -767,7 +1077,40 @@ setEvBind :: EvVar -> EvTerm -> TcS ()
 -- Internal
 setEvBind ev t
   = do { tc_evbinds <- getTcEvBinds
-       ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t }
+       ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t
+
+#ifdef DEBUG
+       ; binds <- getTcEvBindsMap
+       ; let cycle = any (reaches binds) (evterm_evs t)
+       ; when cycle (fail_if_co_loop binds)
+#endif
+       }
+
+#ifdef DEBUG
+  where fail_if_co_loop binds
+          = pprTrace "setEvBind" (vcat [ text "Cycle in evidence binds, evvar =" <+> ppr ev
+                                       , ppr (evBindMapBinds binds) ]) $
+            when (isLCoVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!"))
+
+        reaches :: EvBindMap -> Var -> Bool 
+        -- Does this evvar reach ev? 
+        reaches ebm ev0 = go ev0
+          where go ev0
+                  | ev0 == ev = True
+                  | Just (EvBind _ evtrm) <- lookupEvBind ebm ev0
+                  = any go (evterm_evs evtrm)
+                  | otherwise = False
+
+        evterm_evs (EvId v) = [v]
+        evterm_evs (EvCoercionBox lco) = varSetElems $ coVarsOfCo lco
+        evterm_evs (EvDFunApp _ _ evs) = evs
+        evterm_evs (EvTupleSel v _)    = [v]
+        evterm_evs (EvSuperClass v _)  = [v]
+        evterm_evs (EvCast v co)       = v : varSetElems (coVarsOfCo co)
+        evterm_evs (EvTupleMk evs)     = evs
+#endif
+
+
 
 warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
 warnTcS loc warn_if doc 
@@ -866,9 +1209,9 @@ instDFunTypes mb_inst_tys
     inst_tv (Left tv)  = mkTyVarTy <$> instFlexiTcS tv
     inst_tv (Right ty) = return ty 
 
-instDFunConstraints :: TcThetaType -> TcS [EvVar] 
-instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds 
-
+instDFunConstraints :: TcThetaType -> CtFlavor -> TcS [EvVarCreated] 
+instDFunConstraints preds fl
+  = mapM (newEvVar fl) preds
 
 instFlexiTcS :: TyVar -> TcS TcTyVar 
 -- Like TcM.instMetaTyVar but the variable that is created is always
@@ -890,12 +1233,12 @@ isFlexiTcsTv tv
   | MetaTv TcsTv _ <- tcTyVarDetails tv = True
   | otherwise                           = False
 
-newKindConstraint :: TcTyVar -> Kind -> TcS CoVar
+newKindConstraint :: TcTyVar -> Kind -> CtFlavor -> TcS EvVarCreated
 -- Create new wanted CoVar that constrains the type to have the specified kind. 
-newKindConstraint tv knd 
+newKindConstraint tv knd fl
   = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd 
        ; let ty_k = mkTyVarTy tv_k
-       ; eqv <- newEqVar (mkTyVarTy tv) ty_k
+       ; eqv <- newEqVar fl (mkTyVarTy tv) ty_k
        ; return eqv }
 
 instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar
@@ -910,30 +1253,127 @@ instFlexiTcSHelper tvname tvkind
 -- Superclasses and recursive dictionaries 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
-newEvVar :: TcPredType -> TcS EvVar
-newEvVar pty = wrapTcS $ TcM.newEvVar pty
-
-newDerivedId :: TcPredType -> TcS EvVar 
-newDerivedId pty = wrapTcS $ TcM.newEvVar pty
-
-newGivenEqVar :: 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 
-newGivenEqVar ty1 ty2 co 
-  = do { cv <- newEqVar ty1 ty2
-       ; setEvBind cv (EvCoercionBox co) 
-       ; return cv } 
-
-newEqVar :: TcType -> TcType -> TcS EvVar
-newEqVar ty1 ty2 = wrapTcS $ TcM.newEq ty1 ty2 
+data EvVarCreated 
+  = EvVarCreated { evc_is_new    :: Bool    -- True iff the variable was just created
+                 , evc_the_evvar :: EvVar } -- The actual evidence variable could be cached or new
+
+isNewEvVar :: EvVarCreated -> Bool
+isNewEvVar = evc_is_new
+
+newEvVar :: CtFlavor -> TcPredType -> TcS EvVarCreated
+-- Post: If Given then evc_is_new is True
+-- Hence it is safe to do a setEvBind right after a newEvVar with a Given flavor
+-- NB: newEvVar may temporarily break the TcSEnv invariant but it is expected in 
+--     the call sites for this invariant to be quickly restored.
+newEvVar fl pty
+  | isGivenOrSolved fl    -- Create new variable and update the cache
+  = do { new <- forceNewEvVar fl pty
+       ; return (EvVarCreated True new) }
+
+  | otherwise             -- Otherwise lookup first
+  = do { eref <- getTcSEvVarCache
+       ; ecache <- wrapTcS (TcM.readTcRef eref)
+       ; case lookupTM pty (evc_cache ecache) of
+           Just (cached_evvar, cached_flavor)
+             | cached_flavor `canSolve` fl -- NB: 
+                                           -- We want to use the cache /only/ if he can solve
+                                           -- the workitem. If cached_flavor is Derived
+                                           -- but we have a real Wanted, we want to create
+                                           -- new evidence, otherwise we are in danger to
+                                           -- have unsolved goals in the end. 
+                                           -- (Remember: Derived's are just unification hints
+                                           --            but they don't come with guarantees
+                                           --            that they can be solved and we don't 
+                                           --            quantify over them.
+             -> do { traceTcS "newEvVar"  $  text "already cached, doing nothing"
+                   ; return (EvVarCreated False cached_evvar) }
+           _   -- Not cached or cached with worse flavor
+             -> do { new <- force_new_ev_var eref ecache fl pty
+                   ; return (EvVarCreated True new) } }
+
+forceNewEvVar :: CtFlavor -> TcPredType -> TcS EvVar
+-- Create a new EvVar, regardless of whether or not the
+-- cache already contains one like it, and update the cache
+forceNewEvVar fl pty 
+  = do { eref   <- getTcSEvVarCache
+       ; ecache <- wrapTcS (TcM.readTcRef eref)
+       ; force_new_ev_var eref ecache fl pty }
+
+force_new_ev_var :: IORef EvVarCache -> EvVarCache -> CtFlavor -> TcPredType -> TcS EvVar
+-- Create a new EvVar, and update the cache with it
+force_new_ev_var eref ecache fl pty
+  = wrapTcS $
+    do { TcM.traceTc "newEvVar" $ text "updating cache"
+
+       ; new_evvar <-TcM.newEvVar pty
+            -- This is THE PLACE where we finally call TcM.newEvVar
+
+       ; let new_cache = updateCache ecache (new_evvar,fl,pty)
+       ; TcM.writeTcRef eref new_cache 
+       ; return new_evvar }
+
+updateCache :: EvVarCache -> (EvVar,CtFlavor,Type) -> EvVarCache
+updateCache ecache (ev,fl,pty)
+  | IPPred {} <- classifier
+  = ecache
+  | otherwise
+  = ecache { evc_cache = ecache' }
+  where classifier = classifyPredType pty
+        ecache'    = alterTM pty (\_ -> Just (ev,fl)) $
+                     evc_cache ecache
+
+delCachedEvVar :: EvVar -> TcS ()
+delCachedEvVar ev
+  = do { eref   <- getTcSEvVarCache
+       ; ecache <- wrapTcS (TcM.readTcRef eref)
+       ; wrapTcS $ TcM.writeTcRef eref (delFromCache ecache ev) }
+
+delFromCache :: EvVarCache -> EvVar -> EvVarCache 
+delFromCache (EvVarCache { evc_cache      = ecache
+                         , evc_flat_cache = flat_cache }) ev
+  = EvVarCache { evc_cache = ecache', evc_flat_cache = flat_cache }
+  where ecache' = alterTM pty x_del ecache
+        x_del Nothing = Nothing
+        x_del r@(Just (ev0,_))
+           | ev0 == ev = Nothing
+           | otherwise = r
+        pty = evVarPred ev
+
+
+
+updateFlatCache :: EvVar -> CtFlavor 
+                -> TyCon -> [Xi] -> TcType 
+                -> FlatEqOrigin
+                -> TcS () 
+updateFlatCache ev fl fn xis rhs_ty feq_origin
+  = do { eref <- getTcSEvVarCache
+       ; ecache <- wrapTcS (TcM.readTcRef eref)
+       ; let flat_cache     = evc_flat_cache ecache
+             new_flat_cache = alterTM fun_ty x_flat_cache flat_cache
+             new_evc = ecache { evc_flat_cache = new_flat_cache }
+       ; wrapTcS $ TcM.writeTcRef eref new_evc }
+  where x_flat_cache _ = Just (mkEqVarLCo ev,(rhs_ty,fl,feq_origin))
+        fun_ty = mkTyConApp fn xis
+
+
+pprEvVarCache :: TypeMap (Coercion,a) -> SDoc
+pprEvVarCache tm = ppr (foldTM mk_pair tm [])
+ where mk_pair (co,_) cos = (co, liftedCoercionKind co) : cos
+
+
+newGivenEqVar :: CtFlavor -> TcType -> TcType -> Coercion -> TcS EvVar
+-- Pre: fl is Given
+newGivenEqVar fl ty1 ty2 co 
+  = do { ecv <- newEqVar fl ty1 ty2
+       ; let v = evc_the_evvar ecv -- Will be a new EvVar by post of newEvVar
+       ; setEvBind v (EvCoercionBox co)
+       ; return v }
+
+newEqVar :: CtFlavor -> TcType -> TcType -> TcS EvVarCreated
+newEqVar fl ty1 ty2 
+  = newEvVar fl (mkEqPred (ty1,ty2))
 
-newIPVar :: IPName Name -> TcType -> TcS EvVar 
-newIPVar nm ty = wrapTcS $ TcM.newIP nm ty 
 
-newDictVar :: Class -> [TcType] -> TcS EvVar 
-newDictVar cl tys = wrapTcS $ TcM.newDict cl tys 
 \end{code} 
 
 
@@ -981,3 +1421,98 @@ matchClass clas tys
 matchFam :: TyCon -> [Type] -> TcS (Maybe (TyCon, [Type]))
 matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args
 \end{code}
+
+
+-- Rewriting with respect to the inert equalities 
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+
+getInertEqs :: TcS (TyVarEnv (Ct,Coercion), InScopeSet)
+getInertEqs = do { inert <- getTcSInerts
+                 ; return (inert_eqs inert, inert_eq_tvs inert) }
+
+rewriteFromInertEqs :: (TyVarEnv (Ct,Coercion), InScopeSet)
+                    -- Precondition: Ct are CTyEqCans only!
+                    -> CtFlavor 
+                    -> EvVar 
+                    -> TcS (EvVar,Bool)
+-- Boolean flag returned: True <-> no rewriting happened
+rewriteFromInertEqs (subst,inscope) fl v 
+  = do { let co = liftInertEqsTy (subst,inscope) fl (evVarPred v)
+       ; if isReflCo co then return (v,True)
+         else do { traceTcS "rewriteFromInertEqs" $
+                   text "Original item =" <+> ppr v <+> dcolon <+> ppr (evVarPred v)
+                 ; v' <- forceNewEvVar fl (pSnd (liftedCoercionKind co))
+                 ; case fl of 
+                     Wanted {}  -> setEvBind v (EvCast v' (mkSymCo co)) 
+                     Given {}   -> setEvBind v' (EvCast v co) 
+                     Derived {} -> return ()
+                 ; traceTcS "rewriteFromInertEqs" $
+                   text "Rewritten item =" <+> ppr v' <+> dcolon <+> ppr (evVarPred v')
+                 ; return (v',False) } }
+
+
+-- See Note [LiftInertEqs]
+liftInertEqsTy :: (TyVarEnv (Ct,Coercion),InScopeSet)
+                 -> CtFlavor
+                 -> PredType -> Coercion
+liftInertEqsTy (subst,inscope) fl pty
+  = ty_cts_subst subst inscope fl pty
+
+
+ty_cts_subst :: TyVarEnv (Ct,Coercion)
+             -> InScopeSet -> CtFlavor -> Type -> Coercion
+ty_cts_subst subst inscope fl ty 
+  = go ty 
+  where 
+        go ty = go' ty
+
+        go' (TyVarTy tv)      = tyvar_cts_subst tv `orElse` Refl (TyVarTy tv)
+        go' (AppTy ty1 ty2)   = mkAppCo (go ty1) (go ty2) 
+        go' (TyConApp tc tys) = mkTyConAppCo tc (map go tys)  
+
+        go' (ForAllTy v ty)   = mkForAllCo v' $! co
+                             where 
+                               (subst',inscope',v') = upd_tyvar_bndr subst inscope v
+                               co = ty_cts_subst subst' inscope' fl ty 
+
+        go' (FunTy ty1 ty2)   = mkFunCo (go ty1) (go ty2)
+
+
+        tyvar_cts_subst tv  
+          | Just (ct,co) <- lookupVarEnv subst tv, cc_flavor ct `canRewrite` fl  
+          = Just co -- Warn: use cached, not cc_id directly, because of alpha-renamings!
+          | otherwise = Nothing 
+
+        upd_tyvar_bndr subst inscope v 
+          = (new_subst, (inscope `extendInScopeSet` new_v), new_v)
+          where new_subst 
+                    | no_change = delVarEnv subst v
+                        -- Otherwise we have to extend the environment with /something/. 
+                        -- But we do not want to monadically create a new EvVar. So, we
+                        -- create an 'unused_ct' but we cache reflexivity as the 
+                        -- associated coercion. 
+                    | otherwise = extendVarEnv subst v (unused_ct, Refl (TyVarTy new_v))
+
+                no_change = new_v == v 
+                new_v     = uniqAway inscope v 
+
+                unused_ct = CTyEqCan { cc_id     = unused_evvar
+                                     , cc_flavor = fl -- canRewrite is reflexive.
+                                     , cc_tyvar  = v 
+                                     , cc_rhs    = mkTyVarTy new_v 
+                                     , cc_depth  = unused_depth }
+                unused_depth = panic "ty_cts_subst: This depth should not be accessed!"
+                unused_evvar = panic "ty_cts_subst: This var is just an alpha-renaming!"
+\end{code}
+
+Note [LiftInertEqsPred]
+~~~~~~~~~~~~~~~~~~~~~~~ 
+The function liftInertEqPred behaves almost like liftCoSubst (in
+Coercion), but accepts a map TyVarEnv (Ct,Coercion) instead of a
+LiftCoSubst. This data structure is more convenient to use since we
+must apply the inert substitution /only/ if the inert equality 
+`canRewrite` the work item. There's admittedly some duplication of 
+functionality but it would be more tedious to cache and maintain 
+different flavors of LiftCoSubst structures in the inerts. 
+
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index bd558829d6..be29e38772 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -20,7 +20,7 @@ import TcErrors
 import TcMType
 import TcType 
 import TcSMonad 
-import TcInteract
+import TcInteract 
 import Inst
 import Unify	( niFixTvSubst, niSubstTvSet )
 import Var
@@ -40,6 +40,8 @@ import BasicTypes       ( RuleName )
 import Control.Monad    ( when )
 import Outputable
 import FastString
+import TrieMap
+
 \end{code}
 
 
@@ -62,7 +64,7 @@ simplifyTop wanteds
 simplifyAmbiguityCheck :: Name -> WantedConstraints -> TcM (Bag EvBind)
 simplifyAmbiguityCheck name wanteds
   = simplifyCheck (SimplCheck (ptext (sLit "ambiguity check for") <+> ppr name)) wanteds
-
+ 
 ------------------
 simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
 simplifyInteractive wanteds 
@@ -79,10 +81,9 @@ simplifyDefault theta
 \end{code}
 
 
-
-*********************************************************************************
+***********************************************************************************
 *                                                                                 * 
-*                            Deriving
+*                            Deriving                                             *
 *                                                                                 *
 ***********************************************************************************
 
@@ -111,15 +112,15 @@ simplifyDeriv orig pred tvs theta
 
        ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted)
        ; (residual_wanted, _binds)
-             <- runTcS (SimplInfer doc) NoUntouchables $
-                solveWanteds emptyInert (mkFlatWC wanted)
+             <- solveWanteds (SimplInfer doc) NoUntouchables $
+                mkFlatWC wanted
 
        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
                          -- See Note [Exotic derived instance contexts]
-             get_good :: WantedEvVar -> Either PredType WantedEvVar
-             get_good wev | validDerivPred skol_set p = Left p
-                          | otherwise                 = Right wev
-                          where p = evVarOfPred wev
+             get_good :: Ct -> Either PredType Ct
+             get_good ct | validDerivPred skol_set p = Left p
+                         | otherwise                 = Right ct
+                         where p = evVarPred (cc_id ct)
 
        ; reportUnsolved (residual_wanted { wc_flat = bad })
 
@@ -274,7 +275,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
              , ptext (sLit "surely_fref =") <+> ppr surely_free
              ]
 
-       ; emitFlats surely_free
+       ; emitWantedCts surely_free
        ; traceTc "sinf"  $ vcat
              [ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound
              , ptext (sLit "surely_free   =") <+> ppr surely_free
@@ -283,7 +284,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
             -- Step 2 
        	    -- Now simplify the possibly-bound constraints
        ; (simpl_results, tc_binds0)
-           <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables $
+           <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables emptyInert emptyWorkList $
               simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound })
 
        ; when (insolubleWC simpl_results)  -- Fail fast if there is an insoluble constraint
@@ -294,20 +295,20 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
             -- may have happened, and emit the free constraints. 
        ; gbl_tvs        <- tcGetGlobalTyVars
        ; zonked_tau_tvs <- zonkTcTyVarsAndFV zonked_tau_tvs
-       ; zonked_simples <- zonkWantedEvVars (wc_flat simpl_results)
+       ; zonked_simples <- zonkCts (wc_flat simpl_results)
        ; let init_tvs 	     = zonked_tau_tvs `minusVarSet` gbl_tvs
              poly_qtvs       = growWantedEVs gbl_tvs zonked_simples init_tvs
 	     (pbound, pfree) = partitionBag (quantifyMe poly_qtvs) zonked_simples
 
 	     -- Monomorphism restriction
              mr_qtvs  	     = init_tvs `minusVarSet` constrained_tvs
-             constrained_tvs = tyVarsOfEvVarXs zonked_simples
+             constrained_tvs = tyVarsOfCts zonked_simples
 	     mr_bites        = apply_mr && not (isEmptyBag pbound)
 
              (qtvs, (bound, free))
                 | mr_bites  = (mr_qtvs,   (emptyBag, zonked_simples))
                 | otherwise = (poly_qtvs, (pbound,   pfree))
-       ; emitFlats free
+       ; emitWantedCts free
 
        ; if isEmptyVarSet qtvs && isEmptyBag bound
          then ASSERT( isEmptyBag (wc_insol simpl_results) )
@@ -317,7 +318,8 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds
          else do
 
             -- Step 4, zonk quantified variables 
-       { let minimal_flat_preds = mkMinimalBySCs $ map evVarOfPred $ bagToList bound
+       { let minimal_flat_preds = mkMinimalBySCs $ 
+                                  map (evVarPred . cc_id) $ bagToList bound
              skol_info = InferSkol [ (name, mkSigmaTy [] minimal_flat_preds ty)
                                    | (name, ty) <- name_taus ]
                         -- Don't add the quantified variables here, because
@@ -368,24 +370,41 @@ mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint
 to check the original wanted.
 
 \begin{code}
+
 simplifyWithApprox :: WantedConstraints -> TcS WantedConstraints
 simplifyWithApprox wanted
  = do { traceTcS "simplifyApproxLoop" (ppr wanted)
 
-      ; results <- solveWanteds emptyInert wanted
+      ; let all_flats = wc_flat wanted `unionBags` keepWanted (wc_insol wanted) 
+      ; solveInteractCts $ bagToList all_flats
+      ; unsolved_implics <- simpl_loop 1 (wc_impl wanted)
+
+      ; let (residual_implics,floats) = approximateImplications unsolved_implics
+
+      -- Solve extra stuff for real: notice that all the extra unsolved constraints will 
+      -- be in the inerts of the monad, so we are OK
+      ; traceTcS "simplifyApproxLoop" $ text "Calling solve_wanteds!"
+      ; solve_wanteds (WC { wc_flat  = floats -- They are floated so they are not in the evvar cache
+                          , wc_impl  = residual_implics
+                          , wc_insol = emptyBag })
+      }
 
+
+{- OLD:
+      ; results <- solve_wanteds wanted  
       ; let (residual_implics, floats) = approximateImplications (wc_impl results)
 
         -- If no new work was produced then we are done with simplifyApproxLoop
       ; if insolubleWC results || isEmptyBag floats
         then return results
-
-        else solveWanteds emptyInert
+        else solve_wanteds 
                 (WC { wc_flat = floats `unionBags` wc_flat results
                     , wc_impl = residual_implics
                     , wc_insol = emptyBag }) }
+-}
 
-approximateImplications :: Bag Implication -> (Bag Implication, Bag WantedEvVar)
+
+approximateImplications :: Bag Implication -> (Bag Implication, Cts)
 -- Extracts any nested constraints that don't mention the skolems
 approximateImplications impls
   = do_bag (float_implic emptyVarSet) impls
@@ -395,7 +414,7 @@ approximateImplications impls
     plus :: forall b c. (Bag b, Bag c) -> (Bag b, Bag c) -> (Bag b, Bag c)
     plus (a1,b1) (a2,b2) = (a1 `unionBags` a2, b1 `unionBags` b2)
 
-    float_implic :: TyVarSet -> Implication -> (Bag Implication, Bag WantedEvVar)
+    float_implic :: TyVarSet -> Implication -> (Bag Implication, Cts)
     float_implic skols imp
       = (unitBag (imp { ic_wanted = wanted' }), floats)
       where
@@ -407,10 +426,10 @@ approximateImplications impls
         (flat',   floats1) = do_bag (float_flat   skols) flat
         (implic', floats2) = do_bag (float_implic skols) implic
 
-    float_flat :: TcTyVarSet -> WantedEvVar -> (Bag WantedEvVar, Bag WantedEvVar)
-    float_flat skols wev
-      | tyVarsOfEvVarX wev `disjointVarSet` skols = (emptyBag, unitBag wev)
-      | otherwise                                 = (unitBag wev, emptyBag)
+    float_flat :: TcTyVarSet -> Ct -> (Cts, Cts)
+    float_flat skols ct
+      | tyVarsOfCt ct `disjointVarSet` skols = (emptyBag, unitBag ct)
+      | otherwise                            = (unitBag ct, emptyBag)
 \end{code}
 
 \begin{code}
@@ -422,16 +441,16 @@ approximateImplications impls
 growWanteds :: TyVarSet -> WantedConstraints -> TyVarSet -> TyVarSet
 growWanteds gbl_tvs wc = fixVarSet (growWC gbl_tvs wc)
 
-growWantedEVs :: TyVarSet -> Bag WantedEvVar -> TyVarSet -> TyVarSet
+growWantedEVs :: TyVarSet -> Cts -> TyVarSet -> TyVarSet
 growWantedEVs gbl_tvs ws tvs
   | isEmptyBag ws = tvs
-  | otherwise     = fixVarSet (growPreds gbl_tvs evVarOfPred ws) tvs
+  | otherwise     = fixVarSet (growPreds gbl_tvs (evVarPred . cc_id) ws) tvs
 
 --------  Helper functions, do not do fixpoint ------------------------
 growWC :: TyVarSet -> WantedConstraints -> TyVarSet -> TyVarSet
 growWC gbl_tvs wc = growImplics gbl_tvs             (wc_impl wc) .
-                    growPreds   gbl_tvs evVarOfPred (wc_flat wc) .
-                    growPreds   gbl_tvs evVarOfPred (wc_insol wc)
+                    growPreds   gbl_tvs (evVarPred . cc_id) (wc_flat wc) .
+                    growPreds   gbl_tvs (evVarPred . cc_id) (wc_insol wc)
 
 growImplics :: TyVarSet -> Bag Implication -> TyVarSet -> TyVarSet
 growImplics gbl_tvs implics tvs
@@ -453,13 +472,13 @@ growPreds gbl_tvs get_pred items tvs
 
 --------------------
 quantifyMe :: TyVarSet      -- Quantifying over these
-	   -> WantedEvVar
+	   -> Ct
 	   -> Bool	    -- True <=> quantify over this wanted
-quantifyMe qtvs wev
+quantifyMe qtvs ct
   | isIPPred pred = True  -- Note [Inheriting implicit parameters]
   | otherwise	  = tyVarsOfType pred `intersectsVarSet` qtvs
   where
-    pred = evVarOfPred wev
+    pred = evVarPred (cc_id ct)
 \end{code}
 
 Note [Avoid unecessary constraint simplification]
@@ -584,8 +603,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
 		 -- variables; hence *no untouchables*
 
        ; (lhs_results, lhs_binds)
-              <- runTcS (SimplRuleLhs name) untch $
-                 solveWanteds emptyInert zonked_lhs
+              <- solveWanteds (SimplRuleLhs name) untch zonked_lhs
 
        ; traceTc "simplifyRule" $
          vcat [ text "zonked_lhs"   <+> ppr zonked_lhs 
@@ -595,9 +613,9 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
 
 
        -- Don't quantify over equalities (judgement call here)
-       ; let (eqs, dicts) = partitionBag (isEqPred . evVarOfPred)
+       ; let (eqs, dicts) = partitionBag (isEqPred . evVarPred . cc_id)
                                          (wc_flat lhs_results)
-             lhs_dicts    = map evVarOf (bagToList dicts)
+             lhs_dicts    = map cc_id (bagToList dicts)
                                  -- Dicts and implicit parameters
 
            -- Fail if we have not got down to unsolved flats
@@ -675,8 +693,8 @@ simplifyCheck ctxt wanteds
        ; traceTc "simplifyCheck {" (vcat
              [ ptext (sLit "wanted =") <+> ppr wanteds ])
 
-       ; (unsolved, ev_binds) <- runTcS ctxt NoUntouchables $
-                                 solveWanteds emptyInert wanteds
+       ; (unsolved, ev_binds) <- 
+           solveWanteds ctxt NoUntouchables wanteds
 
        ; traceTc "simplifyCheck }" $
          ptext (sLit "unsolved =") <+> ppr unsolved
@@ -686,22 +704,22 @@ simplifyCheck ctxt wanteds
        ; return ev_binds }
 
 ----------------
-solveWanteds :: InertSet                            -- Given
+solveWanteds :: SimplContext 
+             -> Untouchables
              -> WantedConstraints
-             -> TcS WantedConstraints
-solveWanteds inert wanted
-  = do { (unsolved_flats, unsolved_implics, insols)
-             <- solve_wanteds inert wanted
-       ; return (WC { wc_flat = keepWanted unsolved_flats   -- Discard Derived
-                    , wc_impl = unsolved_implics
-                    , wc_insol = insols }) }
-
-solve_wanteds :: InertSet                            -- Given
-              -> WantedConstraints
-              -> TcS (Bag FlavoredEvVar, Bag Implication, Bag FlavoredEvVar)
--- solve_wanteds iterates when it is able to float equalities
--- out of one or more of the implications
-solve_wanteds inert wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols })
+             -> TcM (WantedConstraints, Bag EvBind)
+-- Returns: residual constraints, plus evidence bindings 
+-- NB: When we are called from TcM there are no inerts to pass down to TcS
+solveWanteds ctxt untch wanted
+  = do { (wc_out, ev_binds) <- runTcS ctxt untch emptyInert emptyWorkList $
+                               solve_wanteds wanted
+       ; let wc_ret = wc_out { wc_flat = keepWanted (wc_flat wc_out) } 
+                      -- Discard Derived
+       ; return (wc_ret, ev_binds) }
+
+solve_wanteds :: WantedConstraints
+              -> TcS WantedConstraints  -- NB: wc_flats may be wanted *or* derived now
+solve_wanteds wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol = insols }) 
   = do { traceTcS "solveWanteds {" (ppr wanted)
 
                  -- Try the flat bit
@@ -710,146 +728,123 @@ solve_wanteds inert wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol =
                  -- everything else.  Solving them a second time is a bit
                  -- of a waste, but the code is simple, and the program is
                  -- wrong anyway!
+
        ; let all_flats = flats `unionBags` keepWanted insols
-       ; inert1 <- solveInteractWanted inert (bagToList all_flats)
+       ; solveInteractCts $ bagToList all_flats
 
-       ; (unsolved_flats, unsolved_implics) <- simpl_loop 1 inert1 implics
+       -- solve_wanteds iterates when it is able to float equalities 
+       -- out of one or more of the implications. 
+       ; unsolved_implics <- simpl_loop 1 implics
 
-       ; bb <- getTcEvBindsBag
+       ; (insoluble_flats,unsolved_flats) <- extractUnsolvedTcS 
+
+       ; bb <- getTcEvBindsMap
        ; tb <- getTcSTyBindsMap
+
        ; traceTcS "solveWanteds }" $
                  vcat [ text "unsolved_flats   =" <+> ppr unsolved_flats
                       , text "unsolved_implics =" <+> ppr unsolved_implics
-                      , text "current evbinds  =" <+> vcat (map ppr (varEnvElts bb))
+                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb)
                       , text "current tybinds  =" <+> vcat (map ppr (varEnvElts tb))
                       ]
 
-       ; (subst, remaining_flats) <- solveCTyFunEqs unsolved_flats
+       ; (subst, remaining_unsolved_flats) <- solveCTyFunEqs unsolved_flats
                 -- See Note [Solving Family Equations]
                 -- NB: remaining_flats has already had subst applied
 
-       ; let (insoluble_flats, unsolved_flats) = partitionBag isCFrozenErr remaining_flats
+       ; return $ 
+         WC { wc_flat  = mapBag (substCt subst) remaining_unsolved_flats
+            , wc_impl  = mapBag (substImplication subst) unsolved_implics
+            , wc_insol = mapBag (substCt subst) insoluble_flats }
+       }
+
+simpl_loop :: Int
+           -> Bag Implication
+           -> TcS (Bag Implication)
+simpl_loop n implics
+  | n > 10 
+  = traceTcS "solveWanteds: loop!" empty >> return implics
+  | otherwise 
+  = do { (implic_eqs, unsolved_implics) <- solveNestedImplications implics
 
-       ; return ( mapBag (substFlavoredEvVar subst . deCanonicalise) unsolved_flats
-                , mapBag (substImplication subst) unsolved_implics
-                , mapBag (substFlavoredEvVar subst . deCanonicalise) insoluble_flats ) }
+       ; inerts <- getTcSInerts
+       ; let ((_,unsolved_flats),_) = extractUnsolved inerts
 
-  where
-    simpl_loop :: Int
-               -> InertSet
-               -> Bag Implication
-               -> TcS (CanonicalCts, Bag Implication) -- CanonicalCts are Wanted or Derived
-    simpl_loop n inert implics
-      | n>10
-      = trace "solveWanteds: loop" $	                -- Always bleat
-        do { traceTcS "solveWanteds: loop" (ppr inert)  -- Bleat more informatively
-           ; let (_, unsolved_cans) = extractUnsolved inert
-           ; return (unsolved_cans, implics) }
-
-      | otherwise
-      = do { traceTcS "solveWanteds: simpl_loop start {" $
-                 vcat [ text "n =" <+> ppr n
-                      , text "implics =" <+> ppr implics
-                      , text "inert   =" <+> ppr inert ]
-           
-           ; let (just_given_inert, unsolved_cans) = extractUnsolved inert
-                     -- unsolved_cans contains either Wanted or Derived!
-
-           ; (implic_eqs, unsolved_implics) 
-                  <- solveNestedImplications just_given_inert unsolved_cans implics
-
-                -- Apply defaulting rules if and only if there
-		-- no floated equalities.  If there are, they may
-		-- solve the remaining wanteds, so don't do defaulting.
-           ; improve_eqs <- if not (isEmptyBag implic_eqs)
-			    then return implic_eqs
-                            else applyDefaultingRules just_given_inert unsolved_cans
-
-           ; traceTcS "solveWanteds: simpl_loop end }" $
-                 vcat [ text "improve_eqs      =" <+> ppr improve_eqs
-                      , text "unsolved_flats   =" <+> ppr unsolved_cans
-                      , text "unsolved_implics =" <+> ppr unsolved_implics ]
-
-           ; (improve_eqs_already_in_inert, inert_with_improvement)
-               <- solveInteract inert improve_eqs 
-
-           ; if improve_eqs_already_in_inert then
-                 return (unsolved_cans, unsolved_implics)
-             else 
-                 simpl_loop (n+1) inert_with_improvement 
-                                         -- Contain unsolved_cans and the improve_eqs
-                                  unsolved_implics
-           }
-
-givensFromWanteds :: SimplContext -> CanonicalCts -> Bag FlavoredEvVar
--- Extract the Wanted ones from CanonicalCts and conver to
--- Givens; not Given/Solved, see Note [Preparing inert set for implications]
-givensFromWanteds _ctxt = foldrBag getWanted emptyBag
-  where
-    getWanted :: CanonicalCt -> Bag FlavoredEvVar -> Bag FlavoredEvVar
-    getWanted cc givens
-      | pushable_wanted cc
-      = let given = mkEvVarX (cc_id cc) (mkGivenFlavor (cc_flavor cc) UnkSkol)
-        in given `consBag` givens     -- and not mkSolvedFlavor,
-                                      -- see Note [Preparing inert set for implications]
-      | otherwise = givens
-
-    pushable_wanted :: CanonicalCt -> Bool 
-    pushable_wanted cc 
-      | not (isCFrozenErr cc) 
-      , isWantedCt cc 
-      = isEqPred (evVarPred (cc_id cc)) -- see Note [Preparing inert set for implications]
-      | otherwise = False 
- 
-solveNestedImplications :: InertSet -> CanonicalCts
-                        -> Bag Implication
-                        -> TcS (Bag FlavoredEvVar, Bag Implication)
-solveNestedImplications just_given_inert unsolved_cans implics
-  | isEmptyBag implics
-  = return (emptyBag, emptyBag)
-  | otherwise 
-  = do {  -- See Note [Preparing inert set for implications]
-	  -- Push the unsolved wanteds inwards, but as givens
-             
-       ; simpl_ctx <- getTcSContext 
+       ; ecache_pre <- getTcSEvVarCacheMap
+       ; let pr = ppr ((\k z m -> foldTM k m z) (:) [] ecache_pre)
+       ; traceTcS "ecache_pre"  $ pr
 
-       ; let pushed_givens    = givensFromWanteds simpl_ctx unsolved_cans
-             tcs_untouchables = filterVarSet isFlexiTcsTv $
-                                tyVarsOfEvVarXs pushed_givens
-             -- See Note [Extra TcsTv untouchables]
+       ; improve_eqs <- if not (isEmptyBag implic_eqs)
+                        then return implic_eqs
+                        else applyDefaultingRules unsolved_flats
 
-       ; traceTcS "solveWanteds: preparing inerts for implications {"  
-                  (vcat [ppr tcs_untouchables, ppr pushed_givens])
+       ; ecache_post <- getTcSEvVarCacheMap
+       ; let po = ppr ((\k z m -> foldTM k m z) (:) [] ecache_post)
+       ; traceTcS "ecache_po"  $ po
 
-       ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens 
+       ; traceTcS "solveWanteds: simpl_loop end" $
+             vcat [ text "improve_eqs      =" <+> ppr improve_eqs
+                  , text "unsolved_flats   =" <+> ppr unsolved_flats
+                  , text "unsolved_implics =" <+> ppr unsolved_implics ]
 
-       ; traceTcS "solveWanteds: } now doing nested implications {" $
-         vcat [ text "inerts_for_implics =" <+> ppr inert_for_implics
-              , text "implics =" <+> ppr implics ]
+       ; if isEmptyBag improve_eqs then return unsolved_implics 
+         else do { solveInteractCts $ bagToList improve_eqs
+                 ; simpl_loop (n+1) unsolved_implics } }
 
-       ; (implic_eqs, unsolved_implics)
-           <- flatMapBagPairM (solveImplication tcs_untouchables inert_for_implics) implics
+solveNestedImplications :: Bag Implication
+                        -> TcS (Cts, Bag Implication)
+-- Precondition: the TcS inerts may contain unsolved flats which have 
+-- to be converted to givens before we go inside a nested implication.
+solveNestedImplications implics
+  | isEmptyBag implics
+  = return (emptyBag, emptyBag)
+  | otherwise 
+  = do { inerts <- getTcSInerts
+       ; let ((_insoluble_flats, unsolved_flats),thinner_inerts) = extractUnsolved inerts 
 
+       ; (implic_eqs, unsolved_implics)
+           <- doWithInert thinner_inerts $ 
+              do { let pushed_givens = givens_from_wanteds unsolved_flats
+                       tcs_untouchables = filterVarSet isFlexiTcsTv $ 
+                                          tyVarsOfCts unsolved_flats
+                 -- See Note [Preparing inert set for implications]
+	         -- Push the unsolved wanteds inwards, but as givens
+                 ; traceTcS "solveWanteds: preparing inerts for implications {" $ 
+                   vcat [ppr tcs_untouchables, ppr pushed_givens]
+                 ; solveInteractCts pushed_givens 
+                 ; traceTcS "solveWanteds: } now doing nested implications {" empty
+                 ; flatMapBagPairM (solveImplication tcs_untouchables) implics }
+
+       -- ... and we are back in the original TcS inerts 
+       -- Notice that the original includes the _insoluble_flats so it was safe to ignore
+       -- them in the beginning of this function.
        ; traceTcS "solveWanteds: done nested implications }" $
                   vcat [ text "implic_eqs ="       <+> ppr implic_eqs
                        , text "unsolved_implics =" <+> ppr unsolved_implics ]
 
        ; return (implic_eqs, unsolved_implics) }
 
-solveImplication :: TcTyVarSet                -- Untouchable TcS unification variables
-                 -> InertSet                  -- Given
-                 -> Implication               -- Wanted
-                 -> TcS (Bag FlavoredEvVar, -- All wanted or derived unifications: var = type
-                         Bag Implication)     -- Unsolved rest (always empty or singleton)
--- Returns: 
---  1. A bag of floatable wanted constraints, not mentioning any skolems, 
---     that are of the form unification var = type
--- 
---  2. Maybe a unsolved implication, empty if entirely solved! 
--- 
--- Precondition: everything is zonked by now
-solveImplication tcs_untouchables inert
-     imp@(Implic { ic_untch  = untch 
+  where givens_from_wanteds = foldrBag get_wanted []
+        get_wanted cc rest_givens
+            | pushable_wanted cc
+            = let this_given = cc { cc_flavor = mkGivenFlavor (cc_flavor cc) UnkSkol }
+              in this_given : rest_givens
+            | otherwise = rest_givens 
+
+        pushable_wanted :: Ct -> Bool 
+        pushable_wanted cc 
+         | isWantedCt cc 
+         = isEqPred (evVarPred (cc_id cc)) -- see Note [Preparing inert set for implications]
+         | otherwise = False 
+
+solveImplication :: TcTyVarSet     -- Untouchable TcS unification variables
+                 -> Implication    -- Wanted
+                 -> TcS (Cts,      -- All wanted or derived floated equalities: var = type
+                         Bag Implication) -- Unsolved rest (always empty or singleton)
+-- Precondition: The TcS monad contains an empty worklist and given-only inerts 
+-- which after trying to solve this implication we must restore to their original value
+solveImplication tcs_untouchables
+     imp@(Implic { ic_untch  = untch
                  , ic_binds  = ev_binds
                  , ic_skols  = skols 
                  , ic_given  = givens
@@ -858,37 +853,41 @@ solveImplication tcs_untouchables inert
   = nestImplicTcS ev_binds (untch, tcs_untouchables) $
     recoverTcS (return (emptyBag, emptyBag)) $
        -- Recover from nested failures.  Even the top level is
-       -- just a bunch of implications, so failing at the first
-       -- one is bad
+       -- just a bunch of implications, so failing at the first one is bad
     do { traceTcS "solveImplication {" (ppr imp) 
 
          -- Solve flat givens
-       ; given_inert <- solveInteractGiven inert loc givens 
+       ; solveInteractGiven loc givens 
 
          -- Simplify the wanteds
-       ; (unsolved_flats, unsolved_implics, insols)
-             <- solve_wanteds given_inert wanteds
+       ; WC { wc_flat = unsolved_flats
+            , wc_impl = unsolved_implics
+            , wc_insol = insols } <- solve_wanteds wanteds
 
        ; let (res_flat_free, res_flat_bound)
                  = floatEqualities skols givens unsolved_flats
              final_flat = keepWanted res_flat_bound
 
-       ; let res_wanted = WC { wc_flat = final_flat
-                             , wc_impl = unsolved_implics
+       ; let res_wanted = WC { wc_flat  = final_flat
+                             , wc_impl  = unsolved_implics
                              , wc_insol = insols }
+
              res_implic = unitImplication $
                           imp { ic_wanted = res_wanted
                               , ic_insol  = insolubleWC res_wanted }
 
+       ; evbinds <- getTcEvBindsMap
+
        ; traceTcS "solveImplication end }" $ vcat
              [ text "res_flat_free =" <+> ppr res_flat_free
+             , text "implication evbinds = " <+> ppr (evBindMapBinds evbinds)
              , text "res_implic =" <+> ppr res_implic ]
 
        ; return (res_flat_free, res_implic) }
+    -- and we are back to the original inerts
 
 
-floatEqualities :: TcTyVarSet -> [EvVar]
-                -> Bag FlavoredEvVar -> (Bag FlavoredEvVar, Bag FlavoredEvVar)
+floatEqualities :: TcTyVarSet -> [EvVar] -> Cts -> (Cts, Cts)
 -- Post: The returned FlavoredEvVar's are only Wanted or Derived
 -- and come from the input wanted ev vars or deriveds 
 floatEqualities skols can_given wantders
@@ -896,11 +895,12 @@ floatEqualities skols can_given wantders
           -- Note [Float Equalities out of Implications]
   | otherwise = partitionBag is_floatable wantders
   
-
-  where is_floatable :: FlavoredEvVar -> Bool
-        is_floatable (EvVarX eqv _fl)
-          | isEqPred (evVarPred eqv) = skols `disjointVarSet` tvs_under_fsks (evVarPred eqv)
-        is_floatable _flev = False
+  where is_floatable :: Ct -> Bool
+        is_floatable ct
+          | ct_predty <- evVarPred (cc_id ct)
+          , isEqPred ct_predty
+          = skols `disjointVarSet` tvs_under_fsks ct_predty
+        is_floatable _ct = False
 
         tvs_under_fsks :: Type -> TyVarSet
         -- ^ NB: for type synonyms tvs_under_fsks does /not/ expand the synonym
@@ -912,7 +912,7 @@ floatEqualities skols can_given wantders
         tvs_under_fsks (FunTy arg res)  = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res
         tvs_under_fsks (AppTy fun arg)  = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg
         tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder 
-        	     	       	      -- can mention type variables!
+        	     	       	        -- can mention type variables!
           | isTyVar tv		      = inner_tvs `delVarSet` tv
           | otherwise  {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) )
                                         inner_tvs `unionVarSet` tvs_under_fsks (tyVarKind tv)
@@ -1041,10 +1041,10 @@ of GADT pattern matches.
 
 \begin{code}
 
-solveCTyFunEqs :: CanonicalCts -> TcS (TvSubst, CanonicalCts)
+solveCTyFunEqs :: Cts -> TcS (TvSubst, Cts)
 -- Default equalities (F xi ~ alpha) by setting (alpha := F xi), whenever possible
 -- See Note [Solving Family Equations]
--- Returns: a bunch of unsolved constraints from the original CanonicalCts and implications
+-- Returns: a bunch of unsolved constraints from the original Cts and implications
 --          where the newly generated equalities (alpha := F xi) have been substituted through.
 solveCTyFunEqs cts
  = do { untch   <- getUntouchables 
@@ -1073,13 +1073,13 @@ extendFunEqBinds (tv_subst, cv_binds) cv tv ty
 
 ------------
 getSolvableCTyFunEqs :: TcsUntouchables
-                     -> CanonicalCts                -- Precondition: all Wanteds or Derived!
-                     -> (CanonicalCts, FunEqBinds)  -- Postcondition: returns the unsolvables
+                     -> Cts                -- Precondition: all Wanteds or Derived!
+                     -> (Cts, FunEqBinds)  -- Postcondition: returns the unsolvables
 getSolvableCTyFunEqs untch cts
-  = Bag.foldlBag dflt_funeq (emptyCCan, emptyFunEqBinds) cts
+  = Bag.foldlBag dflt_funeq (emptyCts, emptyFunEqBinds) cts
   where
-    dflt_funeq :: (CanonicalCts, FunEqBinds) -> CanonicalCt
-               -> (CanonicalCts, FunEqBinds)
+    dflt_funeq :: (Cts, FunEqBinds) -> Ct
+               -> (Cts, FunEqBinds)
     dflt_funeq (cts_in, feb@(tv_subst, _))
                (CFunEqCan { cc_id = cv
                           , cc_flavor = fl
@@ -1105,7 +1105,7 @@ getSolvableCTyFunEqs untch cts
         (cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis))
 
     dflt_funeq (cts_in, fun_eq_binds) ct
-      = (cts_in `extendCCans` ct, fun_eq_binds)
+      = (cts_in `extendCts` ct, fun_eq_binds)
 \end{code}
 
 Note [Solving Family Equations] 
@@ -1166,31 +1166,61 @@ Basic plan behind applyDefaulting rules:
 
 
 \begin{code}
-applyDefaultingRules :: InertSet
-                     -> CanonicalCts             -- All wanteds
-                     -> TcS (Bag FlavoredEvVar)  -- All wanteds again!
+applyDefaultingRules :: Cts      -- All wanteds
+                     -> TcS Cts  -- All wanteds again!
 -- Return some *extra* givens, which express the 
 -- type-class-default choice
-
-applyDefaultingRules inert wanteds
+applyDefaultingRules wanteds
   | isEmptyBag wanteds 
   = return emptyBag
   | otherwise
-  = do { untch <- getUntouchables
+  = do { traceTcS "applyDefaultingRules { " $ 
+                  text "wanteds =" <+> ppr wanteds
+       ; untch <- getUntouchables
        ; tv_cts <- mapM (defaultTyVar untch) $
-                   varSetElems (tyVarsOfCDicts wanteds) 
+                   varSetElems (tyVarsOfCDicts wanteds)
 
        ; info@(_, default_tys, _) <- getDefaultInfo
        ; let groups = findDefaultableGroups info untch wanteds
-       ; deflt_cts <- mapM (disambigGroup default_tys inert) groups
+       ; traceTcS "findDefaultableGroups" $ vcat [ text "groups=" <+> ppr groups
+                                                 , text "untouchables=" <+> ppr  untch 
+                                                 , text "info=" <+> ppr info ]
+       ; deflt_cts <- mapM (disambigGroup default_tys) groups
 
-       ; traceTcS "deflt2" (vcat [ text "Tyvar defaults =" <+> ppr tv_cts
-                                 , text "Type defaults =" <+> ppr deflt_cts])
+       ; traceTcS "applyDefaultingRules }" $ 
+                  vcat [ text "Tyvar defaults =" <+> ppr tv_cts
+                       , text "Type defaults =" <+> ppr deflt_cts]
 
        ; return (unionManyBags deflt_cts `unionBags` unionManyBags tv_cts) }
+\end{code}
+
+Note [tryTcS in defaulting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+defaultTyVar and disambigGroup create new evidence variables for
+default equations, and hence update the EvVar cache. However, after
+applyDefaultingRules we will try to solve these default equations
+using solveInteractCts, which will consult the cache and solve those
+EvVars from themselves! That's wrong.
+
+To avoid this problem we guard defaulting under a @tryTcS@ which leaves
+the original cache unmodified.
 
+There is a second reason for @tryTcS@ in defaulting: disambGroup does
+some constraint solving to determine if a default equation is
+``useful'' in solving some wanted constraints, but we want to
+discharge all evidence and unifications that may have happened during
+this constraint solving.
+
+Finally, @tryTcS@ importantly does not inherit the original cache from
+the higher level but makes up a new cache, the reason is that disambigGroup
+will call solveInteractCts so the new derived and the wanteds must not be 
+in the cache!
+
+
+\begin{code}
 ------------------
-defaultTyVar :: TcsUntouchables -> TcTyVar -> TcS (Bag FlavoredEvVar)
+defaultTyVar :: TcsUntouchables -> TcTyVar -> TcS Cts
 -- defaultTyVar is used on any un-instantiated meta type variables to
 -- default the kind of ? and ?? etc to *.  This is important to ensure
 -- that instance declarations match.  For example consider
@@ -1208,9 +1238,14 @@ defaultTyVar :: TcsUntouchables -> TcTyVar -> TcS (Bag FlavoredEvVar)
 defaultTyVar untch the_tv 
   | isTouchableMetaTyVar_InRange untch the_tv
   , not (k `eqKind` default_k)
-  = do { eqv <- TcSMonad.newKindConstraint the_tv default_k
-       ; let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
-       ; return (unitBag (mkEvVarX eqv (Wanted loc))) }
+  = tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting]
+    do { let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
+             fl  = Wanted loc
+       ; eqv <- TcSMonad.newKindConstraint the_tv default_k fl
+       ; if isNewEvVar eqv then 
+             return $ unitBag (CNonCanonical { cc_id = evc_the_evvar eqv
+                                             , cc_flavor = fl, cc_depth = 0 })
+         else return emptyBag }
   | otherwise            
   = return emptyBag	 -- The common case
   where
@@ -1224,16 +1259,16 @@ findDefaultableGroups
        , [Type]
        , (Bool,Bool) )  -- (Overloaded strings, extended default rules)
     -> TcsUntouchables	-- Untouchable
-    -> CanonicalCts	-- Unsolved
-    -> [[(CanonicalCt,TcTyVar)]]
+    -> Cts	-- Unsolved
+    -> [[(Ct,TcTyVar)]]
 findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) 
                       untch wanteds
   | not (performDefaulting ctxt) = []
   | null default_tys             = []
   | otherwise = filter is_defaultable_group (equivClasses cmp_tv unaries)
   where 
-    unaries     :: [(CanonicalCt, TcTyVar)]  -- (C tv) constraints
-    non_unaries :: [CanonicalCt]             -- and *other* constraints
+    unaries     :: [(Ct, TcTyVar)]  -- (C tv) constraints
+    non_unaries :: [Ct]             -- and *other* constraints
     
     (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds)
         -- Finds unary type-class constraints
@@ -1243,15 +1278,20 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults))
     find_unary cc = Right cc  -- Non unary or non dictionary 
 
     bad_tvs :: TcTyVarSet  -- TyVars mentioned by non-unaries 
-    bad_tvs = foldr (unionVarSet . tyVarsOfCanonical) emptyVarSet non_unaries 
+    bad_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet non_unaries 
 
     cmp_tv (_,tv1) (_,tv2) = tv1 `compare` tv2
 
     is_defaultable_group ds@((_,tv):_)
-        = isTyConableTyVar tv	-- Note [Avoiding spurious errors]
-        && not (tv `elemVarSet` bad_tvs)
-        && isTouchableMetaTyVar_InRange untch tv 
-        && defaultable_classes [cc_class cc | (cc,_) <- ds]
+        = let b1 = isTyConableTyVar tv	-- Note [Avoiding spurious errors]
+              b2 = not (tv `elemVarSet` bad_tvs)
+              b3 = isTouchableMetaTyVar_InRange untch tv 
+              b4 = defaultable_classes [cc_class cc | (cc,_) <- ds]
+          in (b1 && b2 && b3 && b4)
+          {- pprTrace "is_defaultable_group" (vcat [ text "isTyConable   " <+> ppr tv <+> ppr b1 
+                                                   , text "is not in bad " <+> ppr tv <+> ppr b2 
+                                                   , text "is touchable  " <+> ppr tv <+> ppr b3
+                                                   , text "is defaultable" <+> ppr tv <+> ppr b4 ]) -}
     is_defaultable_group [] = panic "defaultable_group"
 
     defaultable_classes clss 
@@ -1271,42 +1311,45 @@ findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults))
     -- Similarly is_std_class
 
 ------------------------------
-disambigGroup :: [Type]                    -- The default types 
-              -> InertSet                  -- Given inert 
-              -> [(CanonicalCt, TcTyVar)]  -- All classes of the form (C a)
-	      	 		           --  sharing same type variable
-              -> TcS (Bag FlavoredEvVar)
+disambigGroup :: [Type]           -- The default types 
+              -> [(Ct, TcTyVar)]  -- All classes of the form (C a)
+	      	 		  --  sharing same type variable
+              -> TcS Cts
 
-disambigGroup [] _inert _grp 
+disambigGroup []  _grp
   = return emptyBag
-disambigGroup (default_ty:default_tys) inert group
+disambigGroup (default_ty:default_tys) group
   = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty)
-       ; eqv <- TcSMonad.newEqVar (mkTyVarTy the_tv) default_ty
-       ; let der_flav = mk_derived_flavor (cc_flavor the_ct)
-             derived_eq = mkEvVarX eqv der_flav
-
-       ; success <- tryTcS $
-                    do { (_,final_inert) <- solveInteract inert $ listToBag $
-                                            derived_eq : wanted_ev_vars
-           	       ; let (_, unsolved) = extractUnsolved final_inert                         
-                       ; let wanted_unsolved = filterBag isWantedCt unsolved 
-                                            -- Don't care about Derived's
-                       ; return (isEmptyBag wanted_unsolved) }
+       ; success <- tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting]
+                    do { let der_flav = mk_derived_flavor (cc_flavor the_ct) 
+                       ; derived_eq <- tryTcS $
+                                       -- I need a new tryTcS because we will call solveInteractCts below!
+                                       do { eqv <- TcSMonad.newEqVar der_flav (mkTyVarTy the_tv) default_ty
+                                          ; return [ CNonCanonical { cc_id = evc_the_evvar eqv
+                                                                   , cc_flavor = der_flav, cc_depth = 0 } ] }
+                       ; traceTcS "disambigGroup (solving) {" 
+                                  (text "trying to solve constraints along with default equations ...") 
+                       ; solveInteractCts (derived_eq ++ wanteds)
+                       ; (_,unsolved) <- extractUnsolvedTcS 
+                       ; traceTcS "disambigGroup (solving) }"
+                                  (text "disambigGroup unsolved =" <+> ppr (keepWanted unsolved))
+                       ; if isEmptyBag (keepWanted unsolved) then -- Don't care about Derived's
+                             return (Just $ listToBag derived_eq) 
+                         else 
+                             return Nothing 
+                       }
        ; case success of
-           True  ->  -- Success: record the type variable binding, and return
-                    do { wrapWarnTcS $ warnDefaulting wanted_ev_vars default_ty
+           Just cts -> -- Success: record the type variable binding, and return
+                    do { wrapWarnTcS $ warnDefaulting wanteds default_ty
                        ; traceTcS "disambigGroup succeeded" (ppr default_ty)
-                       ; return (unitBag derived_eq) }
-           False ->    -- Failure: try with the next type
+                       ; return cts }
+           Nothing -> -- Failure: try with the next type
                     do { traceTcS "disambigGroup failed, will try other default types"
                                   (ppr default_ty)
-                       ; disambigGroup default_tys inert group } }
+                       ; disambigGroup default_tys group } }
   where
     ((the_ct,the_tv):_) = group
     wanteds             = map fst group
-    wanted_ev_vars :: [FlavoredEvVar]
-    wanted_ev_vars      = map deCanonicalise wanteds
-
     mk_derived_flavor :: CtFlavor -> CtFlavor
     mk_derived_flavor (Wanted loc) = Derived loc
     mk_derived_flavor _ = panic "Asked  to disambiguate given or derived!"
@@ -1334,9 +1377,14 @@ already been unified with the rigid variable from g's type sig
 *********************************************************************************
 
 \begin{code}
-newFlatWanteds :: CtOrigin -> ThetaType -> TcM (Bag WantedEvVar)
+newFlatWanteds :: CtOrigin -> ThetaType -> TcM [Ct]
 newFlatWanteds orig theta
   = do { loc <- getCtLoc orig
-       ; evs <- newWantedEvVars theta
-       ; return (listToBag [EvVarX w loc | w <- evs]) }
+       ; mapM (inst_to_wanted loc) theta }
+  where inst_to_wanted loc pty 
+          = do { v <- newWantedEvVar pty 
+               ; return $ 
+                 CNonCanonical { cc_id = v
+                               , cc_flavor = Wanted loc
+                               , cc_depth = 0 } }
 \end{code}
\ No newline at end of file
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 0b9c7bf81c..54bc0cd6e2 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1356,8 +1356,8 @@ reify_tc_app tc tys
          | otherwise                = TH.ConT (reifyName tc)
 
 reifyPred :: TypeRep.PredType -> TcM TH.Pred
-reifyPred ty = case predTypePredTree ty of
-  ClassPred cls tys -> do { tys' <- reifyTypes tys
+reifyPred ty = case classifyPredType ty of
+  ClassPred cls tys -> do { tys' <- reifyTypes tys 
                           ; return $ TH.ClassP (reifyName cls) tys' }
   IPPred _ _        -> noTH (sLit "implicit parameters") (ppr ty)
   EqPred ty1 ty2    -> do { ty1' <- reifyType ty1
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index a81a909dd0..018655b04d 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -1013,7 +1013,7 @@ tcInstHeadTyAppAllTyVars ty
 Deconstructors and tests on predicate types
 
 \begin{code}
--- | Like 'predTypePredTree' but doesn't look through type synonyms.
+-- | Like 'classifyPredType' but doesn't look through type synonyms.
 -- Used to check that programs only use "simple" contexts without any
 -- synonyms in them.
 shallowPredTypePredTree :: PredType -> PredTree
@@ -1029,7 +1029,7 @@ shallowPredTypePredTree ev_ty
          , let [ty] = tys
          -> IPPred ip ty
       () | isTupleTyCon tc
-         -> TuplePred (map shallowPredTypePredTree tys)
+         -> TuplePred tys
       _ -> IrredPred ev_ty
   | otherwise
   = IrredPred ev_ty
@@ -1061,31 +1061,32 @@ mkMinimalBySCs :: [PredType] -> [PredType]
 mkMinimalBySCs ptys = [ ploc |  ploc <- ptys
                              ,  ploc `not_in_preds` rec_scs ]
  where
-   rec_scs = concatMap (trans_super_classes . predTypePredTree) ptys
+   rec_scs = concatMap trans_super_classes ptys
    not_in_preds p ps = null (filter (eqPred p) ps)
-   trans_super_classes (ClassPred cls tys) = transSuperClasses cls tys
-   trans_super_classes (TuplePred ts)      = concatMap trans_super_classes ts
-   trans_super_classes _other_pty          = []
+
+   trans_super_classes pred   -- Superclasses of pred, excluding pred itself
+     = case classifyPredType pred of
+         ClassPred cls tys -> transSuperClasses cls tys
+         TuplePred ts      -> concatMap trans_super_classes ts
+         _                 -> []
 
 transSuperClasses :: Class -> [Type] -> [PredType]
-transSuperClasses cls tys
-  = foldl (\pts p -> trans_sc p ++ pts) [] $
-    immSuperClasses cls tys
-  where trans_sc :: PredType -> [PredType]
-        trans_sc = trans_sc' . predTypePredTree
-
-        trans_sc' :: PredTree -> [PredType]
-        trans_sc' ptree@(ClassPred cls tys)
-          = foldl (\pts p -> trans_sc p ++ pts) [predTreePredType ptree] $
-            immSuperClasses cls tys
-        trans_sc' ptree@(TuplePred ts)
-          = foldl (\pts t -> trans_sc' t ++ pts) [predTreePredType ptree] ts
-        trans_sc' ptree = [predTreePredType ptree]
+transSuperClasses cls tys    -- Superclasses of (cls tys),
+                             -- excluding (cls tys) itself
+  = concatMap trans_sc (immSuperClasses cls tys)
+  where 
+    trans_sc :: PredType -> [PredType]
+    -- (trans_sc p) returns (p : p's superclasses)
+    trans_sc p = case classifyPredType p of
+                   ClassPred cls tys -> p : transSuperClasses cls tys
+                   TuplePred ps      -> concatMap trans_sc ps
+                   _                 -> [p]
 
 immSuperClasses :: Class -> [Type] -> [PredType]
 immSuperClasses cls tys
   = substTheta (zipTopTvSubst tyvars tys) sc_theta
-  where (tyvars,sc_theta,_,_) = classBigSig cls
+  where 
+    (tyvars,sc_theta,_,_) = classBigSig cls
 \end{code}
 
 
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 44854fdf94..0717b0150f 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -20,8 +20,8 @@ module Coercion (
         LCoercion,
 
         -- ** Functions over coercions
-        coVarKind, coVarKind_maybe,
-        coercionType, coercionKind, coercionKinds, isReflCo,
+        coVarKind,
+        coercionType, coercionKind, coercionKinds, isReflCo, liftedCoercionKind,
         mkCoercionType,
 
 	-- ** Constructing coercions
@@ -41,7 +41,7 @@ module Coercion (
         splitForAllCo_maybe,
 
 	-- ** Coercion variables
-	mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique,
+	mkCoVar, isCoVar, isCoVarType, isLCoVar, coVarName, setCoVarName, setCoVarUnique,
 
         -- ** Free variables
         tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize,
@@ -90,7 +90,7 @@ import BasicTypes
 import Outputable
 import Unique
 import Pair
-import PrelNames	( funTyConKey, eqPrimTyConKey )
+import PrelNames	( funTyConKey, eqPrimTyConKey, eqTyConKey )
 import Control.Applicative
 import Data.Traversable (traverse, sequenceA)
 import Control.Arrow (second)
@@ -127,6 +127,7 @@ data Coercion
   | TyConAppCo TyCon [Coercion]    -- lift TyConApp 
     	       -- The TyCon is never a synonym; 
 	       -- we expand synonyms eagerly
+	       -- But it can be a type function
 
   | AppCo Coercion Coercion        -- lift AppTy
 
@@ -312,6 +313,14 @@ setCoVarName   = setVarName
 isCoVar :: Var -> Bool
 isCoVar v = isCoVarType (varType v)
 
+isLCoVar :: Var -> Bool 
+-- Is lifted coercion variable (only!)
+isLCoVar v 
+  | Just tc <- tyConAppTyCon_maybe (varType v) 
+  , tc `hasKey` eqTyConKey
+  = True
+  | otherwise = False 
+
 isCoVarType :: Type -> Bool
 isCoVarType ty 	    -- Tests for t1 ~# t2, the unboxed equality
   | Just tc <- tyConAppTyCon_maybe ty = tc `hasKey` eqPrimTyConKey
@@ -391,20 +400,16 @@ pprParendCo co = ppr_co TyConPrec co
 ppr_co :: Prec -> Coercion -> SDoc
 ppr_co _ (Refl ty) = angles (ppr ty)
 
-ppr_co p co@(TyConAppCo tc cos)
+ppr_co p co@(TyConAppCo tc [_,_])
   | tc `hasKey` funTyConKey = ppr_fun_co p co
-  | otherwise               = pprTcApp   p ppr_co tc cos
-
-ppr_co p (AppCo co1 co2)    = maybeParen p TyConPrec $
-                              pprCo co1 <+> ppr_co TyConPrec co2
-
-ppr_co p co@(ForAllCo {}) = ppr_forall_co p co
-
-ppr_co _ (CoVarCo cv)     = parenSymOcc (getOccName cv) (ppr cv)
 
+ppr_co p (TyConAppCo tc cos)   = pprTcApp   p ppr_co tc cos
+ppr_co p (AppCo co1 co2)       = maybeParen p TyConPrec $
+                                 pprCo co1 <+> ppr_co TyConPrec co2
+ppr_co p co@(ForAllCo {})      = ppr_forall_co p co
+ppr_co _ (CoVarCo cv)          = parenSymOcc (getOccName cv) (ppr cv)
 ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos
 
-
 ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $
                              ppr_co FunPrec co1
                              <+> ptext (sLit ";")
@@ -412,7 +417,8 @@ ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $
 ppr_co p (InstCo co ty) = maybeParen p TyConPrec $
                           pprParendCo co <> ptext (sLit "@") <> pprType ty
 
-ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) [pprParendType ty1, pprParendType ty2]
+ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) 
+                                           [pprParendType ty1, pprParendType ty2]
 ppr_co p (SymCo co)         = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co]
 ppr_co p (NthCo n co)       = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendCo co]
 
@@ -423,6 +429,7 @@ angles p = char '<' <> p <> char '>'
 ppr_fun_co :: Prec -> Coercion -> SDoc
 ppr_fun_co p co = pprArrowChain p (split co)
   where
+    split :: Coercion -> [SDoc]
     split (TyConAppCo f [arg,res])
       | f `hasKey` funTyConKey
       = ppr_co FunPrec arg : split res
@@ -494,15 +501,19 @@ splitForAllCo_maybe _                = Nothing
 -- and some coercion kind stuff
 
 coVarKind :: CoVar -> (Type,Type) 
--- c :: t1 ~ t2
-coVarKind cv = case coVarKind_maybe cv of
-                 Just ts -> ts
-                 Nothing -> pprPanic "coVarKind" (ppr cv $$ ppr (tyVarKind cv))
+coVarKind cv
+ | Just (tc, [_kind,ty1,ty2]) <- splitTyConApp_maybe (varType cv)
+ = ASSERT (tc `hasKey` eqPrimTyConKey)
+   (ty1,ty2)
+ | otherwise = panic "coVarKind, non coercion variable"
+
+liftedCoVarKind :: EqVar -> (Type,Type)
+liftedCoVarKind cv
+ | Just (tc, [_kind,ty1,ty2]) <- splitTyConApp_maybe (varType cv)
+ = ASSERT (tc `hasKey` eqTyConKey)
+   (ty1,ty2)
+ | otherwise = panic "liftedCoVarKind, non coercion variable"
 
-coVarKind_maybe :: CoVar -> Maybe (Type,Type) 
-coVarKind_maybe cv = case splitTyConApp_maybe (varType cv) of
-  Just (tc, [_, ty1, ty2]) | tc `hasKey` eqPrimTyConKey -> Just (ty1, ty2)
-  _ -> Nothing
 
 -- | Makes a coercion type from two types: the types whose equality 
 -- is proven by the relevant 'Coercion'
@@ -526,6 +537,7 @@ isReflCo_maybe _         = Nothing
 
 \begin{code}
 mkCoVarCo :: CoVar -> Coercion
+-- cv :: s ~# t
 mkCoVarCo cv
   | ty1 `eqType` ty2 = Refl ty1
   | otherwise        = CoVarCo cv
@@ -533,6 +545,7 @@ mkCoVarCo cv
     (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv
 
 mkEqVarLCo :: EqVar -> LCoercion
+-- ipv :: s ~ t  (the boxed equality type)
 mkEqVarLCo ipv
   | ty1 `eqType` ty2 = Refl ty1
   | otherwise        = CoVarCo ipv
@@ -1077,22 +1090,32 @@ coercionType co = case coercionKind co of
 -- > c :: (t1 ~ t2)
 --
 -- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.
-coercionKind :: Coercion -> Pair Type
-coercionKind (Refl ty)            = Pair ty ty
-coercionKind (TyConAppCo tc cos)  = mkTyConApp tc <$> (sequenceA $ map coercionKind cos)
-coercionKind (AppCo co1 co2)      = mkAppTy <$> coercionKind co1 <*> coercionKind co2
-coercionKind (ForAllCo tv co)     = mkForAllTy tv <$> coercionKind co
-coercionKind (CoVarCo cv)         = ASSERT( isCoVar cv ) toPair $ coVarKind cv
-coercionKind (AxiomInstCo ax cos) = let Pair tys1 tys2 = coercionKinds cos
-                                    in  Pair (substTyWith (co_ax_tvs ax) tys1 (co_ax_lhs ax)) 
-                                             (substTyWith (co_ax_tvs ax) tys2 (co_ax_rhs ax))
-coercionKind (UnsafeCo ty1 ty2)   = Pair ty1 ty2
-coercionKind (SymCo co)           = swap $ coercionKind co
-coercionKind (TransCo co1 co2)    = Pair (pFst $ coercionKind co1) (pSnd $ coercionKind co2)
-coercionKind (NthCo d co)         = getNth d <$> coercionKind co
-coercionKind co@(InstCo aco ty)    | Just ks <- splitForAllTy_maybe `traverse` coercionKind aco
-                                  = (\(tv, body) -> substTyWith [tv] [ty] body) <$> ks
-				  | otherwise = pprPanic "coercionKind" (ppr co)
+
+liftedCoercionKind :: LCoercion -> Pair Type
+liftedCoercionKind = coercion_kind liftedCoVarKind 
+
+coercionKind :: Coercion -> Pair Type 
+coercionKind = coercion_kind coVarKind
+                                
+coercion_kind :: (CoVar -> (Type,Type)) -> Coercion -> Pair Type
+-- Works for Coercions and LCoercions but you have to pass in what to do 
+-- at the (unlifted or lifted) coercion variable. 
+coercion_kind f co = go co 
+  where go (Refl ty)            = Pair ty ty
+        go (TyConAppCo tc cos)  = mkTyConApp tc <$> (sequenceA $ map go cos)
+        go (AppCo co1 co2)      = mkAppTy <$> go co1 <*> go co2
+        go (ForAllCo tv co)     = mkForAllTy tv <$> go co
+        go (CoVarCo cv)         = toPair $ f cv
+        go (AxiomInstCo ax cos) = let Pair tys1 tys2 = (sequenceA $ map go cos) 
+                                  in  Pair (substTyWith (co_ax_tvs ax) tys1 (co_ax_lhs ax)) 
+                                           (substTyWith (co_ax_tvs ax) tys2 (co_ax_rhs ax))
+        go (UnsafeCo ty1 ty2)   = Pair ty1 ty2
+        go (SymCo co)           = swap $ go co
+        go (TransCo co1 co2)    = Pair (pFst $ go co1) (pSnd $ go co2)
+        go (NthCo d co)         = getNth d <$> go co
+        go co@(InstCo aco ty)    | Just ks <- splitForAllTy_maybe `traverse` go aco
+                                          = (\(tv, body) -> substTyWith [tv] [ty] body) <$> ks
+        				  | otherwise = pprPanic "coercionKind" (ppr co)
 
 -- | Apply 'coercionKind' to multiple 'Coercion's
 coercionKinds :: [Coercion] -> Pair [Type]
diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 03b4b0a55e..70eabb441a 100644
--- a/compiler/types/FunDeps.lhs
+++ b/compiler/types/FunDeps.lhs
@@ -140,11 +140,11 @@ oclose preds fixed_tvs
 	      ]
      
     classesOfPredTy :: PredType -> [(Class, [Type])]
-    classesOfPredTy = go . predTypePredTree
-      where
-       go (ClassPred cls tys) = [(cls, tys)]
-       go (TuplePred ts)      = concatMap go ts
-       go _                   = []
+    classesOfPredTy pred
+       = case classifyPredType pred of
+            ClassPred cls tys -> [(cls, tys)]
+            TuplePred ts      -> concatMap classesOfPredTy ts
+            _                 -> []
 \end{code}
 
     
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 0557ab60bd..cb253d82fc 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -54,7 +54,7 @@ module Type (
         mkPrimEqType,
 
         -- Deconstructing predicate types
-        PredTree(..), predTreePredType, predTypePredTree,
+        PredTree(..), predTreePredType, classifyPredType,
         getClassPredTys, getClassPredTys_maybe,
         getEqPredTys, getEqPredTys_maybe,
         getIPPredTy_maybe,
@@ -881,18 +881,18 @@ Decomposing PredType
 data PredTree = ClassPred Class [Type]
               | EqPred Type Type
               | IPPred (IPName Name) Type
-              | TuplePred [PredTree]
+              | TuplePred [PredType]
               | IrredPred PredType
 
 predTreePredType :: PredTree -> PredType
 predTreePredType (ClassPred clas tys) = mkClassPred clas tys
 predTreePredType (EqPred ty1 ty2)     = mkEqPred (ty1, ty2)
 predTreePredType (IPPred ip ty)       = mkIPPred ip ty
-predTreePredType (TuplePred tys)      = mkBoxedTupleTy (map predTreePredType tys)
+predTreePredType (TuplePred tys)      = mkBoxedTupleTy tys
 predTreePredType (IrredPred ty)       = ty
 
-predTypePredTree :: PredType -> PredTree
-predTypePredTree ev_ty = case splitTyConApp_maybe ev_ty of
+classifyPredType :: PredType -> PredTree
+classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of
     Just (tc, tys) | Just clas <- tyConClass_maybe tc
                    -> ClassPred clas tys
     Just (tc, tys) | tc `hasKey` eqTyConKey
@@ -902,7 +902,7 @@ predTypePredTree ev_ty = case splitTyConApp_maybe ev_ty of
                    , let [ty] = tys
                    -> IPPred ip ty
     Just (tc, tys) | isTupleTyCon tc
-                   -> TuplePred (map predTypePredTree tys)
+                   -> TuplePred tys
     _ -> IrredPred ev_ty
 \end{code}
 
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index ced5e961d7..ea95c606ae 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -1,4 +1,4 @@
-%
+ | %
 % (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1998
 %
@@ -477,16 +477,15 @@ pprParendKind = pprParendType
 
 ------------------
 pprEqPred :: Pair Type -> SDoc
-pprEqPred = ppr_eq_pred ppr_type
-
-ppr_eq_pred :: (Prec -> a -> SDoc) -> Pair a -> SDoc
-ppr_eq_pred pp (Pair ty1 ty2) = sep [ pp FunPrec ty1
-                                    , nest 2 (ptext (sLit "~"))
-                                    , pp FunPrec ty2]
-			       -- Precedence looks like (->) so that we get
-			       --    Maybe a ~ Bool
-			       --    (a->a) ~ Bool
-			       -- Note parens on the latter!
+-- NB: Maybe move to Coercion? It's only called after coercionKind anyway. 
+pprEqPred (Pair ty1 ty2) 
+  = sep [ ppr_type FunPrec ty1
+        , nest 2 (ptext (sLit "~#"))
+        , ppr_type FunPrec ty2]
+    -- Precedence looks like (->) so that we get
+    --    Maybe a ~ Bool
+    --    (a->a) ~ Bool
+    -- Note parens on the latter!
 
 ------------
 pprClassPred :: Class -> [Type] -> SDoc
diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs
index 18191ca732..977815f51f 100644
--- a/compiler/vectorise/Vectorise/Type/PRepr.hs
+++ b/compiler/vectorise/Vectorise/Type/PRepr.hs
@@ -217,7 +217,7 @@ buildToArrPRepr vect_tc prepr_tc pdata_tc r
 
       return . Lam arg
              $ mkWildCase scrut (mkTyConApp pdata_tc ty_args) res_ty
-               [(DataAlt pdata_dc, vars, mkCoerce co result)]
+               [(DataAlt pdata_dc, vars, mkCast result co)]
   where
     ty_args = mkTyVarTys $ tyConTyVars vect_tc
     el_ty   = mkTyConApp vect_tc ty_args
@@ -292,7 +292,7 @@ buildFromArrPRepr vect_tc prepr_tc pdata_tc r
           co           = mkAppCo pdata_co
                        $ mkAxInstCo repr_co var_tys
 
-          scrut  = mkCoerce co (Var arg)
+          scrut  = mkCast (Var arg) co
 
           mk_result args = wrapFamInstBody pdata_tc var_tys
                          $ mkConApp pdata_con
diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs
index 836a363b78..5a38ecd557 100644
--- a/compiler/vectorise/Vectorise/Utils/PADict.hs
+++ b/compiler/vectorise/Vectorise/Utils/PADict.hs
@@ -122,7 +122,7 @@ prDictOfPReprInstTyCon ty prepr_tc prepr_args
       let co = mkAppCo pr_co
              $ mkSymCo
              $ mkAxInstCo arg_co prepr_args
-      return $ mkCoerce co dict
+      return $ mkCast dict co
 
   | otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty)