Merge branch 'master' of http://darcs.haskell.org//ghc

53 files changed, 1836 insertions, 1693 deletions

diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 9515612405..39d5a845b8 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -203,9 +203,6 @@ pprStmt platform stmt = case stmt of
                         pprCFunType (pprCLabel platform lbl) cconv results args <>
                         noreturn_attr <> semi
 
-        fun_proto lbl = ptext (sLit ";EF_(") <>
-                         pprCLabel platform lbl <> char ')' <> semi
-
         noreturn_attr = case ret of
                           CmmNeverReturns -> text "__attribute__ ((noreturn))"
                           CmmMayReturn    -> empty
@@ -226,12 +223,7 @@ pprStmt platform stmt = case stmt of
                     let myCall = pprCall platform (pprCLabel platform lbl) cconv results args
                     in (real_fun_proto lbl, myCall)
                 | not (isMathFun lbl) ->
-                    let myCall = braces (
-                                     pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
-                                  $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
-                                  $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
-                                 )
-                    in (fun_proto lbl, myCall)
+                    pprForeignCall platform (pprCLabel platform lbl) cconv results args
               _ ->
                    (empty {- no proto -},
                     pprCall platform cast_fn cconv results args <> semi)
@@ -241,19 +233,36 @@ pprStmt platform stmt = case stmt of
         vcat $ map (pprStmt platform) stmts
 
     CmmCall (CmmPrim op _) results args _ret ->
-        pprCall platform ppr_fn CCallConv results args'
-        where
-        ppr_fn = pprCallishMachOp_for_C op
-        -- The mem primops carry an extra alignment arg, must drop it.
-        -- We could maybe emit an alignment directive using this info.
-        args'  | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args
-               | otherwise = args
+        proto $$ fn_call
+      where
+        cconv = CCallConv
+        fn = pprCallishMachOp_for_C op
+        (proto, fn_call)
+          -- The mem primops carry an extra alignment arg, must drop it.
+          -- We could maybe emit an alignment directive using this info.
+          -- We also need to cast mem primops to prevent conflicts with GCC
+          -- builtins (see bug #5967).
+          | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
+          = pprForeignCall platform fn cconv results (init args)
+          | otherwise
+          = (empty, pprCall platform fn cconv results args)
 
     CmmBranch ident          -> pprBranch ident
     CmmCondBranch expr ident -> pprCondBranch platform expr ident
     CmmJump lbl _            -> mkJMP_(pprExpr platform lbl) <> semi
     CmmSwitch arg ids        -> pprSwitch platform arg ids
 
+pprForeignCall :: Platform -> SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> (SDoc, SDoc)
+pprForeignCall platform fn cconv results args = (proto, fn_call)
+  where
+    fn_call = braces (
+                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
+              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
+              $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
+             )
+    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
+    proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
+
 pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
 pprCFunType ppr_fn cconv ress args
   = res_type ress <+>
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 249861a4e4..7c392c48f2 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -663,7 +663,7 @@ arityType env (App fun arg )
 	-- The difference is observable using 'seq'
 	--
 arityType env (Case scrut _ _ alts)
-  | exprIsBottom scrut 
+  | exprIsBottom scrut || null alts
   = ABot 0     -- Do not eta expand
                -- See Note [Dealing with bottom (1)]
   | otherwise
@@ -829,14 +829,18 @@ etaInfoApp subst (Cast e co1) eis
   where
     co' = CoreSubst.substCo subst co1
 
-etaInfoApp subst (Case e b _ alts) eis 
-  = Case (subst_expr subst e) b1 (coreAltsType alts') alts'
+etaInfoApp subst (Case e b ty alts) eis 
+  = Case (subst_expr subst e) b1 (mk_alts_ty (CoreSubst.substTy subst ty) eis) alts'
   where
     (subst1, b1) = substBndr subst b
     alts' = map subst_alt alts
     subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) 
     	      where
 	      	 (subst2,bs') = substBndrs subst1 bs
+
+    mk_alts_ty ty []               = ty
+    mk_alts_ty ty (EtaVar v : eis) = mk_alts_ty (applyTypeToArg ty (varToCoreExpr v)) eis
+    mk_alts_ty _  (EtaCo co : eis) = mk_alts_ty (pSnd (coercionKind co)) eis
     
 etaInfoApp subst (Let b e) eis 
   = Let b' (etaInfoApp subst' e eis)
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 369f1a308e..eb3cd5e948 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -486,7 +486,7 @@ freeVars (Case scrut bndr ty alts)
     scrut2 = freeVars scrut
 
     (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
-    alts_fvs            = foldr1 unionFVs alts_fvs_s
+    alts_fvs            = foldr unionFVs noFVs alts_fvs_s
 
     fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
                              (con, args, rhs2))
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 4af5b1c143..41b0f3bd2f 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -498,9 +498,6 @@ checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
 --     the simplifer correctly eliminates case that can't 
 --     possibly match.
 
-checkCaseAlts e _ []
-  = addErrL (mkNullAltsMsg e)
-
 checkCaseAlts e ty alts = 
   do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
      ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
@@ -1116,11 +1113,6 @@ pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
 ------------------------------------------------------
 --	Messages for case expressions
 
-mkNullAltsMsg :: CoreExpr -> MsgDoc
-mkNullAltsMsg e 
-  = hang (text "Case expression with no alternatives:")
-	 4 (ppr e)
-
 mkDefaultArgsMsg :: [Var] -> MsgDoc
 mkDefaultArgsMsg args 
   = hang (text "DEFAULT case with binders")
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 29810755c7..bfe6dec72e 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -221,7 +221,8 @@ These data types are the heart of the compiler
 --    This is one of the more complicated elements of the Core language, 
 --    and comes with a number of restrictions:
 --    
---    1. The list of alternatives is non-empty
+--    1. The list of alternatives may be empty; 
+--       See Note [Empty case alternatives]
 --
 --    2. The 'DEFAULT' case alternative must be first in the list, 
 --       if it occurs at all.
@@ -338,11 +339,59 @@ Note [CoreSyn let goal]
   application, its arguments are trivial, so that the constructor can be
   inlined vigorously.
 
-
 Note [Type let]
 ~~~~~~~~~~~~~~~
 See #type_let#
 
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The alternatives of a case expression should be exhaustive.  A case expression
+can have empty alternatives if (and only if) the scrutinee is bound to raise
+an exception or diverge.  So:
+   Case (error Int "Hello") b Bool []
+is fine, and has type Bool.  This is one reason we need a type on 
+the case expression: if the alternatives are empty we can't get the type
+from the alternatives!  I'll write this
+   case (error Int "Hello") of Bool {}
+with the return type just before the alterantives.
+
+Here's another example:
+  data T
+  f :: T -> Bool
+  f = \(x:t). case x of Bool {}
+Since T has no data constructors, the case alterantives are of course
+empty.  However note that 'x' is not bound to a visbily-bottom value;
+it's the *type* that tells us it's going to diverge.  Its a bit of a
+degnerate situation but we do NOT want to replace
+   case x of Bool {}   -->   error Bool "Inaccessible case"
+because x might raise an exception, and *that*'s what we want to see!
+(Trac #6067 is an example.) To preserve semantics we'd have to say
+   x `seq` error Bool "Inaccessible case"   
+ but the 'seq' is just a case, so we are back to square 1.  Or I suppose
+we could say
+   x |> UnsafeCoerce T Bool
+but that loses all trace of the fact that this originated with an empty
+set of alternatives.
+
+We can use the empty-alternative construct to coerce error values from
+one type to another.  For example
+
+    f :: Int -> Int
+    f n = error "urk"
+   
+    g :: Int -> (# Char, Bool #)
+    g x = case f x of { 0 -> ..., n -> ... }
+
+Then if we inline f in g's RHS we get
+    case (error Int "urk") of (# Char, Bool #) { ... }
+and we can discard the alternatives since the scrutinee is bottom to give
+    case (error Int "urk") of (# Char, Bool #) {}
+
+This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),
+if for no other reason that we don't need to instantiate the (~) at an 
+unboxed type.
+
+
 %************************************************************************
 %*									*
               Ticks
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 4ab1bec131..5817669fe7 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -392,8 +392,8 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 
     size_up (Case (Var v) _ _ alts) 
 	| v `elem` top_args		-- We are scrutinising an argument variable
-	= alts_size (foldr1 addAltSize alt_sizes)
-		    (foldr1 maxSize alt_sizes)
+	= alts_size (foldr addAltSize sizeZero alt_sizes)
+		    (foldr maxSize    sizeZero alt_sizes)
 		-- Good to inline if an arg is scrutinised, because
 		-- that may eliminate allocation in the caller
 		-- And it eliminates the case itself
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 35063350ef..34046e8159 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -187,15 +187,7 @@ mkCast (Coercion e_co) co
        -- The guard here checks that g has a (~#) on both sides,
        -- otherwise decomposeCo fails.  Can in principle happen
        -- with unsafeCoerce
-  = 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
+  = Coercion (mkCoCast e_co co)
 
 mkCast (Cast expr co2) co
   = ASSERT(let { Pair  from_ty  _to_ty  = coercionKind co;
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 9e42290f7e..53386fec02 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -13,7 +13,7 @@ module MkCore (
         mkCoreApp, mkCoreApps, mkCoreConApps,
         mkCoreLams, mkWildCase, mkIfThenElse,
         mkWildValBinder, mkWildEvBinder,
-        sortQuantVars,
+        sortQuantVars, castBottomExpr,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
@@ -209,6 +209,16 @@ mkIfThenElse guard then_expr else_expr
   = mkWildCase guard boolTy (exprType then_expr) 
 	 [ (DataAlt falseDataCon, [], else_expr),	-- Increasing order of tag!
     	   (DataAlt trueDataCon,  [], then_expr) ]
+
+castBottomExpr :: CoreExpr -> Type -> CoreExpr
+-- (castBottomExpr e ty), assuming that 'e' diverges, 
+-- return an expression of type 'ty'
+-- See Note [Empty case alternatives] in CoreSyn
+castBottomExpr e res_ty
+  | e_ty `eqType` res_ty = e
+  | otherwise            = Case e (mkWildValBinder e_ty) res_ty []
+  where
+    e_ty = exprType e
 \end{code}
 
 The functions from this point don't really do anything cleverer than
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 2d0ad237fc..ec7adf543f 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -620,12 +620,11 @@ addTickStmt isGuard (ExprStmt e bind' guard' ty) = do
 addTickStmt _isGuard (LetStmt binds) = do
 	liftM LetStmt
 		(addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do
-    liftM4 ParStmt 
+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
+    liftM3 ParStmt 
         (mapM (addTickStmtAndBinders isGuard) pairs)
         (addTickSyntaxExpr hpcSrcSpan mzipExpr)
         (addTickSyntaxExpr hpcSrcSpan bindExpr)
-        (addTickSyntaxExpr hpcSrcSpan returnExpr)
 
 addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
                                     , trS_by = by, trS_using = using
@@ -652,12 +651,13 @@ addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
                   | otherwise          = addTickLHsExprRHS e
 
-addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ([LStmt Id], a) 
-                      -> TM ([LStmt Id], a)
-addTickStmtAndBinders isGuard (stmts, ids) = 
-    liftM2 (,) 
+addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
+                      -> TM (ParStmtBlock Id Id)
+addTickStmtAndBinders isGuard (ParStmtBlock stmts ids returnExpr) = 
+    liftM3 ParStmtBlock 
         (addTickLStmts isGuard stmts)
         (return ids)
+        (addTickSyntaxExpr hpcSrcSpan returnExpr)
 
 addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id)
 addTickHsLocalBinds (HsValBinds binds) = 
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 663c289d3c..1da6a77976 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -1124,8 +1124,8 @@ collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 collectStmtBinders (ExprStmt {})        = []
 collectStmtBinders (LastStmt {})        = []
-collectStmtBinders (ParStmt xs _ _ _)   = collectLStmtsBinders
-                                        $ concatMap fst xs
+collectStmtBinders (ParStmt xs _ _)     = collectLStmtsBinders
+                                        $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]
 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
 collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
 
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 8fc6bd91f3..eae9530b0e 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -18,7 +18,7 @@ lower levels it is preserved with @let@/@letrec@s).
 -- for details
 
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-                 dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion
+                 dsHsWrapper, dsTcEvBinds, dsEvBinds
   ) where
 
 #include "HsVersions.h"
@@ -32,7 +32,6 @@ import DsUtils
 
 import HsSyn		-- lots of things
 import CoreSyn		-- lots of things
-import HscTypes         ( MonadThings )
 import Literal          ( Literal(MachStr) )
 import CoreSubst
 import MkCore
@@ -40,6 +39,8 @@ import CoreUtils
 import CoreArity ( etaExpand )
 import CoreUnfold
 import CoreFVs
+import UniqSupply
+import Unique( Unique )
 import Digraph
 
 
@@ -52,7 +53,7 @@ import TysWiredIn ( eqBoxDataCon, tupleCon )
 import Id
 import Class
 import DataCon	( dataConWorkId )
-import Name	( Name, localiseName )
+import Name
 import MkId	( seqId )
 import Var
 import VarSet
@@ -662,7 +663,7 @@ but it seems better to reject the program because it's almost certainly
 a mistake.  That's what the isDeadBinder call detects.
 
 Note [Constant rule dicts]
-~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~
 When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict, 
 which is presumably in scope at the function definition site, we can quantify 
 over it too.  *Any* dict with that type will do.
@@ -695,23 +696,23 @@ as the old one, but with an Internal name and no IdInfo.
 
 
 \begin{code}
-dsHsWrapper :: MonadThings m => HsWrapper -> CoreExpr -> m CoreExpr
+dsHsWrapper :: HsWrapper -> CoreExpr -> DsM CoreExpr
 dsHsWrapper WpHole 	      e = return e
 dsHsWrapper (WpTyApp ty)      e = return $ App e (Type ty)
 dsHsWrapper (WpLet ev_binds)  e = do bs <- dsTcEvBinds ev_binds
                                      return (mkCoreLets bs e)
 dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
-dsHsWrapper (WpCast co)       e = return $ dsTcCoercion co (mkCast e) 
+dsHsWrapper (WpCast co)       e = dsTcCoercion co (mkCast e) 
 dsHsWrapper (WpEvLam ev)      e = return $ Lam ev e 
 dsHsWrapper (WpTyLam tv)      e = return $ Lam tv e 
 dsHsWrapper (WpEvApp evtrm)   e = liftM (App e) (dsEvTerm evtrm)
 
 --------------------------------------
-dsTcEvBinds :: MonadThings m => TcEvBinds -> m [CoreBind]
+dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
 
-dsEvBinds :: MonadThings m => Bag EvBind -> m [CoreBind]
+dsEvBinds :: Bag EvBind -> DsM [CoreBind]
 dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
   where
     ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
@@ -726,39 +727,51 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
     edges = foldrBag ((:) . mk_node) [] bs 
 
     mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
-    mk_node b@(EvBind var term) = (b, var, evVarsOfTerm term)
+    mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))
 
 
 ---------------------------------------
-dsEvTerm :: MonadThings m => EvTerm -> m CoreExpr
+dsEvTerm :: EvTerm -> DsM CoreExpr
 dsEvTerm (EvId v) = return (Var v)
 
-dsEvTerm (EvCast v co) 
-  = return $ dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
-                                     -- unnecessary to call varToCoreExpr v here.
+dsEvTerm (EvCast tm co) 
+  = do { tm' <- dsEvTerm tm
+       ; dsTcCoercion co $ mkCast tm' }
+                        -- 'v' is always a lifted evidence variable so it is
+                        -- unnecessary to call varToCoreExpr v here.
+
 dsEvTerm (EvKindCast v co)
-  = return $ dsTcCoercion co $ (\_ -> Var v)
+  = do { v' <- dsEvTerm v
+       ; dsTcCoercion co $ (\_ -> v') }
 
-dsEvTerm (EvDFunApp df tys vars) = return (Var df `mkTyApps` tys `mkVarApps` vars)
-dsEvTerm (EvCoercion co)         = return $ dsTcCoercion co mkEqBox
+dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
+                                     ; return (Var df `mkTyApps` tys `mkApps` tms') }
+dsEvTerm (EvCoercion co)         = dsTcCoercion co mkEqBox
 dsEvTerm (EvTupleSel v n)
-   = ASSERT( isTupleTyCon tc )
-     return $
-     Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
-  where
-    (tc, tys) = splitTyConApp (evVarPred v)
-    Just [dc] = tyConDataCons_maybe tc
-    v' = v `setVarType` ty_want
-    xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
-    (tys_before, ty_want:tys_after) = splitAt n tys
-dsEvTerm (EvTupleMk vs) = return $ Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
-  where dc = tupleCon ConstraintTuple (length vs)
-        tys = map varType vs
+   = do { tm' <- dsEvTerm v
+        ; let scrut_ty = exprType tm'
+              (tc, tys) = splitTyConApp scrut_ty
+    	      Just [dc] = tyConDataCons_maybe tc
+    	      xs = mkTemplateLocals tys
+              the_x = xs !! n
+        ; ASSERT( isTupleTyCon tc )
+          return $
+          Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] }
+
+dsEvTerm (EvTupleMk tms) 
+  = do { tms' <- mapM dsEvTerm tms
+       ; let tys = map exprType tms'
+       ; return $ Var (dataConWorkId dc) `mkTyApps` tys `mkApps` tms' }
+  where 
+    dc = tupleCon ConstraintTuple (length tms)
+
 dsEvTerm (EvSuperClass d n)
-  = return $ Var sc_sel_id `mkTyApps` tys `App` Var d
+  = do { d' <- dsEvTerm d
+       ; let (cls, tys) = getClassPredTys (exprType d')
+             sc_sel_id  = classSCSelId cls n	-- Zero-indexed
+       ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
   where
-    sc_sel_id  = classSCSelId cls n	-- Zero-indexed
-    (cls, tys) = getClassPredTys (evVarPred d)   
+
 dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg]
   where 
     errorId = rUNTIME_ERROR_ID
@@ -770,7 +783,7 @@ dsEvTerm (EvLit l) =
     EvStr s -> mkStringExprFS s
 
 ---------------------------------------
-dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
+dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
 -- This is the crucial function that moves 
 -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
 -- e.g.  dsTcCoercion (trans g1 g2) k
@@ -778,22 +791,28 @@ dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
 --         case g2 of EqBox g2# ->
 --         k (trans g1# g2#)
 dsTcCoercion co thing_inside
-  = foldr wrap_in_case result_expr eqvs_covs
-  where
-    result_expr = thing_inside (ds_tc_coercion subst co)
-    result_ty   = exprType result_expr
+  = do { us <- newUniqueSupply
+       ; let eqvs_covs :: [(EqVar,CoVar)]
+             eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
+                                           (uniqsFromSupply us)
 
-    -- We use the same uniques for the EqVars and the CoVars, and just change
-    -- the type. So the CoVars shadow the EqVars
+             subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
+             result_expr = thing_inside (ds_tc_coercion subst co)
+             result_ty   = exprType result_expr
 
-    eqvs_covs :: [(EqVar,CoVar)]
-    eqvs_covs = [(eqv, eqv `setIdType` mkCoercionType ty1 ty2)
-                | eqv <- varSetElems (coVarsOfTcCo co)
-                , let (ty1, ty2) = getEqPredTys (evVarPred eqv)]
 
-    subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
-
-    wrap_in_case (eqv, cov) body 
+       ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
+  where
+    mk_co_var :: Id -> Unique -> (Id, Id)
+    mk_co_var eqv uniq = (eqv, mkUserLocal occ uniq ty loc)
+       where
+         eq_nm = idName eqv
+         occ = nameOccName eq_nm
+         loc = nameSrcSpan eq_nm
+         ty  = mkCoercionType ty1 ty2
+         (ty1, ty2) = getEqPredTys (evVarPred eqv)
+
+    wrap_in_case result_ty (eqv, cov) body 
       = Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
 
 ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
@@ -816,6 +835,7 @@ ds_tc_coercion subst tc_co
     go (TcNthCo n co)         = mkNthCo n (go co)
     go (TcInstCo co ty)       = mkInstCo (go co) ty
     go (TcLetCo bs co)        = ds_tc_coercion (ds_co_binds bs) co
+    go (TcCastCo co1 co2)     = mkCoCast (go co1) (go co2)
     go (TcCoVarCo v)          = ds_ev_id subst v
 
     ds_co_binds :: TcEvBinds -> CvSubst
diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs
index 917e8b19ed..c3c52188fe 100644
--- a/compiler/deSugar/DsListComp.lhs
+++ b/compiler/deSugar/DsListComp.lhs
@@ -19,7 +19,6 @@ import TcHsSyn
 import CoreSyn
 import MkCore
 
-import TcEvidence
 import DsMonad          -- the monadery used in the desugarer
 import DsUtils
 
@@ -71,15 +70,15 @@ dsListComp lquals res_ty = do
     -- mix of possibly a single element in length, so we do this to leave the possibility open
     isParallelComp = any isParallelStmt
 
-    isParallelStmt (ParStmt _ _ _ _) = True
-    isParallelStmt _                 = False
+    isParallelStmt (ParStmt {}) = True
+    isParallelStmt _            = False
 
 
 -- This function lets you desugar a inner list comprehension and a list of the binders
 -- of that comprehension that we need in the outer comprehension into such an expression
 -- and the type of the elements that it outputs (tuples of binders)
-dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type)
-dsInnerListComp (stmts, bndrs)
+dsInnerListComp :: (ParStmtBlock Id Id) -> DsM (CoreExpr, Type)
+dsInnerListComp (ParStmtBlock stmts bndrs _)
   = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)])
                             (mkListTy bndrs_tuple_type)
        ; return (expr, bndrs_tuple_type) }
@@ -98,7 +97,7 @@ dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderM
         to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
 
     -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
-    (expr, from_tup_ty) <- dsInnerListComp (stmts, from_bndrs)
+    (expr, from_tup_ty) <- dsInnerListComp (ParStmtBlock stmts from_bndrs noSyntaxExpr)
 
     -- Work out what arguments should be supplied to that expression: i.e. is an extraction
     -- function required? If so, create that desugared function and add to arguments
@@ -233,7 +232,7 @@ deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
     core_list1 <- dsLExpr list1
     deBindComp pat core_list1 quals core_list2
 
-deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
+deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list
   = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
        ; let (exps, qual_tys) = unzip exps_and_qual_tys
 
@@ -243,7 +242,7 @@ deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list
        ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
                     quals list }
   where
-        bndrs_s = map snd stmtss_w_bndrs
+        bndrs_s = [bs | ParStmtBlock _ bs _ <- stmtss_w_bndrs]
 
         -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
         pat  = mkBigLHsPatTup pats
@@ -473,7 +472,7 @@ dsPArrComp :: [Stmt Id]
             -> DsM CoreExpr
 
 -- Special case for parallel comprehension
-dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals
+dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals
 
 -- Special case for simple generators:
 --
@@ -590,7 +589,7 @@ dePArrComp (LetStmt ds : qs) pa cea = do
 -- singeltons qualifier lists, which we already special case in the caller.
 -- So, encountering one here is a bug.
 --
-dePArrComp (ParStmt _ _ _ _ : _) _ _ =
+dePArrComp (ParStmt {} : _) _ _ =
   panic "DsListComp.dePArrComp: malformed comprehension AST: ParStmt"
 dePArrComp (TransStmt {} : _) _ _ = panic "DsListComp.dePArrComp: TransStmt"
 dePArrComp (RecStmt   {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
@@ -601,7 +600,7 @@ dePArrComp (RecStmt   {} : _) _ _ = panic "DsListComp.dePArrComp: RecStmt"
 --    where
 --      {x_1, ..., x_n} = DV (qs)
 --
-dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr
+dePArrParComp :: [ParStmtBlock Id Id] -> [Stmt Id] -> DsM CoreExpr
 dePArrParComp qss quals = do
     (pQss, ceQss) <- deParStmt qss
     dePArrComp quals pQss ceQss
@@ -609,13 +608,13 @@ dePArrParComp qss quals = do
     deParStmt []             =
       -- empty parallel statement lists have no source representation
       panic "DsListComp.dePArrComp: Empty parallel list comprehension"
-    deParStmt ((qs, xs):qss) = do        -- first statement
+    deParStmt (ParStmtBlock qs xs _:qss) = do        -- first statement
       let res_expr = mkLHsVarTuple xs
       cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr])
       parStmts qss (mkLHsVarPatTup xs) cqs
     ---
     parStmts []             pa cea = return (pa, cea)
-    parStmts ((qs, xs):qss) pa cea = do  -- subsequent statements (zip'ed)
+    parStmts (ParStmtBlock qs xs _:qss) pa cea = do  -- subsequent statements (zip'ed)
       zipP <- dsDPHBuiltin zipPVar
       let pa'      = mkLHsPatTup [pa, mkLHsVarPatTup xs]
           ty'cea   = parrElemType cea
@@ -763,12 +762,12 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
 --   mzip :: forall a b. m a -> m b -> m (a,b)
 -- NB: we need a polymorphic mzip because we call it several times
 
-dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
- = do  { exps_w_tys  <- mapM ds_inner pairs   -- Pairs (exp :: m ty, ty)
+dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest
+ = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)
        ; mzip_op'    <- dsExpr mzip_op
 
        ; let -- The pattern variables
-             pats = map (mkBigLHsVarPatTup . snd) pairs
+             pats = [ mkBigLHsVarPatTup bs | ParStmtBlock _ bs _ <- blocks]
              -- Pattern with tuples of variables
              -- [v1,v2,v3]  =>  (v1, (v2, v3))
              pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
@@ -779,11 +778,9 @@ dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest
 
        ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
   where
-    ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op
-                                 ; return (exp, tup_ty) }
-       where
-         mono_ret_op = HsWrap (WpTyApp tup_ty) return_op
-         tup_ty      = mkBigCoreVarTupTy bndrs
+    ds_inner (ParStmtBlock stmts bndrs return_op) 
+       = do { exp <- dsInnerMonadComp stmts bndrs return_op
+            ; return (exp, mkBigCoreVarTupTy bndrs) }
 
 dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
 
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index 505c985bbe..a3005db41b 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -493,11 +493,11 @@ compiler/main/Constants_HC_OPTS  += -fforce-recomp
 # LibFFI.hs #includes ffi.h
 compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS)
 # On Windows it seems we also need to link directly to libffi
-ifeq  "$(HOSTPLATFORM)" "i386-unknown-mingw32"
+ifeq "$(HostOS_CPP)" "mingw32"
 define windowsDynLinkToFfi
 # $1 = way
 ifneq "$$(findstring dyn, $1)" ""
-compiler_stage2_$1_ALL_HC_OPTS += -lffi-5
+compiler_stage2_$1_ALL_HC_OPTS += -l$$(LIBFFI_WINDOWS_LIB)
 endif
 endef
 $(foreach way,$(GhcLibWays),$(eval $(call windowsDynLinkToFfi,$(way))))
diff --git a/compiler/ghci/LibFFI.hsc b/compiler/ghci/LibFFI.hsc
index d54307973e..9bdabda0c2 100644
--- a/compiler/ghci/LibFFI.hsc
+++ b/compiler/ghci/LibFFI.hsc
@@ -57,7 +57,7 @@ prepForeignCall cconv arg_types result_type
     
 convToABI :: CCallConv -> C_ffi_abi
 convToABI CCallConv   = fFI_DEFAULT_ABI
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
 convToABI StdCallConv = fFI_STDCALL
 #endif
 -- unknown conventions are mapped to the default, (#3336)
@@ -111,7 +111,7 @@ fFI_OK            = (#const FFI_OK)
 
 fFI_DEFAULT_ABI :: C_ffi_abi
 fFI_DEFAULT_ABI = (#const FFI_DEFAULT_ABI)
-#ifdef mingw32_HOST_OS
+#if defined(mingw32_HOST_OS) && defined(i386_HOST_ARCH)
 fFI_STDCALL     :: C_ffi_abi
 fFI_STDCALL     = (#const FFI_STDCALL)
 #endif
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 2ee7692052..7e8ceb6695 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -652,9 +652,9 @@ cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkExprStmt e' }
 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
                             ; returnL $ LetStmt ds' }
-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr }
+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
 		       where
-			 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
+			 cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
 
 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
 cvtMatch (TH.Match p body decs)
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 08d1281f13..349c001cc8 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -875,11 +875,9 @@ data StmtLR idL idR
   | LetStmt  (HsLocalBindsLR idL idR)
 
   -- ParStmts only occur in a list/monad comprehension
-  | ParStmt  [([LStmt idL], [idR])]
+  | ParStmt  [ParStmtBlock idL idR]
              (SyntaxExpr idR)           -- Polymorphic `mzip` for monad comprehensions
              (SyntaxExpr idR)           -- The `>>=` operator
-             (SyntaxExpr idR)           -- Polymorphic `return` operator
-	     		 		-- with type (forall a. a -> m a)
                                         -- See notes [Monad Comprehensions]
   	    -- After renaming, the ids are the binders 
   	    -- bound by the stmts and used after themp
@@ -943,6 +941,13 @@ data TransForm	 -- The 'f' below is the 'using' function, 'e' is the by function
   = ThenForm     -- then f               or    then f by e             (depending on trS_by)
   | GroupForm	   -- then group using f   or    then group by e using f (depending on trS_by)
   deriving (Data, Typeable)
+
+data ParStmtBlock idL idR
+  = ParStmtBlock 
+        [LStmt idL] 
+        [idR]              -- The variables to be returned
+        (SyntaxExpr idR)   -- The return operator
+  deriving( Data, Typeable )
 \end{code}
 
 Note [The type of bind in Stmts]
@@ -1082,6 +1087,10 @@ In any other context than 'MonadComp', the fields for most of these
 
 
 \begin{code}
+instance (OutputableBndr idL, OutputableBndr idR) 
+      => Outputable (ParStmtBlock idL idR) where
+  ppr (ParStmtBlock stmts _ _) = interpp'SP stmts
+
 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where
     ppr stmt = pprStmt stmt
 
@@ -1090,11 +1099,10 @@ pprStmt (LastStmt expr _)         = ifPprDebug (ptext (sLit "[last]")) <+> ppr e
 pprStmt (BindStmt pat expr _ _)   = hsep [ppr pat, ptext (sLit "<-"), ppr expr]
 pprStmt (LetStmt binds)           = hsep [ptext (sLit "let"), pprBinds binds]
 pprStmt (ExprStmt expr _ _ _)     = ppr expr
-pprStmt (ParStmt stmtss _ _ _)    = hsep (map doStmts stmtss)
-  where doStmts stmts = ptext (sLit "| ") <> ppr stmts
+pprStmt (ParStmt stmtss _ _)      = sep (punctuate (ptext (sLit " | ")) (map ppr stmtss))
 
 pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
-  = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form])
+  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
 
 pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids
                  , recS_later_ids = later_ids })
@@ -1138,16 +1146,17 @@ ppr_do_stmts stmts
   = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts))
            <+> rbrace
 
-ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc]
-ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts]
-
 pprComp :: OutputableBndr id => [LStmt id] -> SDoc
 pprComp quals	  -- Prints:  body | qual1, ..., qualn 
   | not (null quals)
   , L _ (LastStmt body _) <- last quals
-  = hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals))
+  = hang (ppr body <+> char '|') 2 (pprQuals (dropTail 1 quals))
   | otherwise
-  = pprPanic "pprComp" (interpp'SP quals)
+  = pprPanic "pprComp" (pprQuals quals)
+
+pprQuals :: OutputableBndr id => [LStmt id] -> SDoc
+-- Show list comprehension qualifiers separated by commas
+pprQuals quals = interpp'SP quals
 \end{code}
 
 %************************************************************************
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index cf54de467d..8ac04761fe 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -93,7 +93,7 @@ import SrcLoc
 import FastString
 import Util
 import Bag
-
+import Outputable
 import Data.Either
 \end{code}
 
@@ -216,7 +216,8 @@ mkGroupUsingStmt   :: [LStmt idL]                -> LHsExpr idR -> StmtLR idL id
 mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR
 
 emptyTransStmt :: StmtLR idL idR
-emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] 
+emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
+                           , trS_stmts = [], trS_bndrs = [] 
                            , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
                            , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
                            , trS_fmap = noSyntaxExpr }
@@ -538,8 +539,8 @@ collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 collectStmtBinders (ExprStmt {})        = []
 collectStmtBinders (LastStmt {})        = []
-collectStmtBinders (ParStmt xs _ _ _)   = collectLStmtsBinders
-                                        $ concatMap fst xs
+collectStmtBinders (ParStmt xs _ _)     = collectLStmtsBinders
+                                        $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
 collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
 
@@ -714,8 +715,7 @@ lStmtsImplicits = hs_lstmts
     hs_stmt (LetStmt binds)      = hs_local_binds binds
     hs_stmt (ExprStmt {})        = emptyNameSet
     hs_stmt (LastStmt {})        = emptyNameSet
-    hs_stmt (ParStmt xs _ _ _)   = hs_lstmts $ concatMap fst xs
-    
+    hs_stmt (ParStmt xs _ _)     = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
     hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
     
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index eff699fd6b..3ef6d0998a 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1124,6 +1124,10 @@ instance Binary IfaceExpr where
         putByte bh 12
         put_ bh ie
         put_ bh ico
+    put_ bh (IfaceECase a b) = do
+        putByte bh 13
+        put_ bh a
+        put_ bh b
     get bh = do
         h <- getByte bh
         case h of
@@ -1162,6 +1166,9 @@ instance Binary IfaceExpr where
             12 -> do ie <- get bh
                      ico <- get bh
                      return (IfaceCast ie ico)
+            13 -> do a <- get bh
+                     b <- get bh
+                     return (IfaceECase a b)
             _ -> panic ("get IfaceExpr " ++ show h)
 
 instance Binary IfaceConAlt where
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index d3e44fe54f..b53398da7d 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -249,6 +249,7 @@ data IfaceExpr
   | IfaceLam 	IfaceBndr IfaceExpr
   | IfaceApp 	IfaceExpr IfaceExpr
   | IfaceCase	IfaceExpr IfLclName [IfaceAlt]
+  | IfaceECase  IfaceExpr IfaceType     -- See Note [Empty case alternatives]
   | IfaceLet	IfaceBinding  IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
   | IfaceLit    Literal
@@ -279,6 +280,12 @@ data IfaceBinding
 data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo
 \end{code}
 
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In IfaceSyn an IfaceCase does not record the types of the alternatives,
+unlike CorSyn Case.  But we need this type if the alternatives are empty.
+Hence IfaceECase.  See Note [Empty case alternatives] in CoreSyn.
+
 Note [Expose recursive functions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For supercompilation we want to put *all* unfoldings in the interface
@@ -621,6 +628,11 @@ pprIfaceExpr add_par i@(IfaceLam _ _)
     collect bs (IfaceLam b e) = collect (b:bs) e
     collect bs e              = (reverse bs, e)
 
+pprIfaceExpr add_par (IfaceECase scrut ty)
+  = add_par (sep [ ptext (sLit "case") <+> pprIfaceExpr noParens scrut 
+                 , ptext (sLit "ret_ty") <+> pprParendIfaceType ty
+                 , ptext (sLit "of {}") ])
+
 pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
   = add_par (sep [ptext (sLit "case") 
 			<+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
@@ -856,7 +868,7 @@ freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
 freeNamesIfExpr (IfaceApp f a)    = freeNamesIfExpr f &&& freeNamesIfExpr a
 freeNamesIfExpr (IfaceCast e co)  = freeNamesIfExpr e &&& freeNamesIfType co
 freeNamesIfExpr (IfaceTick _ e)   = freeNamesIfExpr e
-
+freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
 freeNamesIfExpr (IfaceCase s _ alts)
   = freeNamesIfExpr s 
     &&& fnList fn_alt alts &&& fn_cons alts
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 3c8050cff2..0ccab30ae5 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1767,7 +1767,9 @@ toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)
 toIfaceExpr (Coercion co)   = IfaceCo   (coToIfaceType co)
 toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
 toIfaceExpr (App f a)       = toIfaceApp f [a]
-toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
+toIfaceExpr (Case s x ty as) 
+  | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)
+  | otherwise               = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
 toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)
 toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (coToIfaceType co)
 toIfaceExpr (Tick t e)    = IfaceTick (toIfaceTickish t) (toIfaceExpr e)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index badb3c70aa..e7360dc935 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -32,6 +32,7 @@ import CoreUtils
 import CoreUnfold
 import CoreLint
 import WorkWrap
+import MkCore( castBottomExpr )
 import Id
 import MkId
 import IdInfo
@@ -467,7 +468,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
                                   ifSynKind = kind })
    = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
      { tc_name  <- lookupIfaceTop occ_name
-     ; rhs_kind <- tcIfaceType kind     -- Note [Synonym kind loop]
+     ; rhs_kind <- tcIfaceKind kind     -- Note [Synonym kind loop]
      ; rhs      <- forkM (mk_doc tc_name) $ 
                    tc_syn_rhs mb_rhs_ty
      ; tycon    <- buildSynTyCon tc_name tyvars rhs rhs_kind parent
@@ -868,17 +869,29 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
 
 \begin{code}
 tcIfaceType :: IfaceType -> IfL Type
-tcIfaceType (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
-tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
-tcIfaceType (IfaceLitTy l)        = do { l1 <- tcIfaceTyLit l; return (LitTy l1) }
-tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
-tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
+tcIfaceType (IfaceTyVar n)         = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
+tcIfaceType (IfaceAppTy t1 t2)     = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
+tcIfaceType (IfaceLitTy l)         = do { l1 <- tcIfaceTyLit l; return (LitTy l1) }
+tcIfaceType (IfaceFunTy t1 t2)     = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
+tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
+                                        ; tks' <- tcIfaceTcArgs (tyConKind tc') tks 
+                                        ; return (mkTyConApp tc' tks') }
 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
 tcIfaceType t@(IfaceCoConApp {})  = pprPanic "tcIfaceType" (ppr t)
 
 tcIfaceTypes :: [IfaceType] -> IfL [Type]
 tcIfaceTypes tys = mapM tcIfaceType tys
 
+tcIfaceTcArgs :: Kind -> [IfaceType] -> IfL [Type]
+tcIfaceTcArgs _ [] 
+  = return []
+tcIfaceTcArgs kind (tk:tks)
+  = case splitForAllTy_maybe kind of
+      Nothing         -> tcIfaceTypes (tk:tks)
+      Just (_, kind') -> do { k'   <- tcIfaceKind tk
+                            ; tks' <- tcIfaceTcArgs kind' tks
+                            ; return (k':tks') }
+  
 -----------------------------------------
 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
 tcIfaceCtxt sts = mapM tcIfaceType sts
@@ -887,8 +900,44 @@ tcIfaceCtxt sts = mapM tcIfaceType sts
 tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
 tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
 tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
+
+-----------------------------------------
+tcIfaceKind :: IfaceKind -> IfL Kind   -- See Note [Checking IfaceTypes vs IfaceKinds]
+tcIfaceKind (IfaceTyVar n)        = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
+tcIfaceKind (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') }
+tcIfaceKind (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') }
+tcIfaceKind (IfaceTyConApp tc ts) = do { tc' <- tcIfaceKindCon tc; ts' <- tcIfaceKinds ts; return (mkTyConApp tc' ts') }
+tcIfaceKind (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceKind t; return (ForAllTy tv' t') }
+tcIfaceKind t                     = pprPanic "tcIfaceKind" (ppr t)  -- IfaceCoApp, IfaceLitTy
+
+tcIfaceKinds :: [IfaceKind] -> IfL [Kind]
+tcIfaceKinds tys = mapM tcIfaceKind tys
 \end{code}
 
+Note [Checking IfaceTypes vs IfaceKinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to know whether we are checking a *type* or a *kind*.
+Consider   module M where
+             Proxy :: forall k. k -> *
+             data T = T
+and consider the two IfaceTypes
+      M.Proxy * M.T{tc}
+      M.Proxy 'M.T{tc} 'M.T(d}
+The first is conventional, but in the latter we use the promoted
+type constructor (as a kind) and data constructor (as a type).  However, 
+the Name of the promoted type constructor is just M.T; it's the *same name*
+as the ordinary type constructor.  
+
+We could add a "promoted" flag to an IfaceTyCon, but that's a bit heavy.
+Instead we use context to distinguish, as in the source language.  
+  - When checking a kind, we look up M.T{tc} and promote it
+  - When checking a type, we look up M.T{tc} and don't promote it
+                                 and M.T{d}  and promote it
+    See tcIfaceKindCon and tcIfaceKTyCon respectively
+
+This context business is why we need tcIfaceTcArgs.
+
+
 %************************************************************************
 %*                                                                      *
                         Coercions
@@ -971,6 +1020,11 @@ tcIfaceExpr (IfaceLam bndr body)
 tcIfaceExpr (IfaceApp fun arg)
   = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
 
+tcIfaceExpr (IfaceECase scrut ty) 
+  = do { scrut' <- tcIfaceExpr scrut 
+       ; ty' <- tcIfaceType ty
+       ; return (castBottomExpr scrut' ty') }
+
 tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
     scrut' <- tcIfaceExpr scrut
     case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
@@ -1312,6 +1366,17 @@ tcIfaceTyCon (IfaceTc name)
            ADataCon dc -> return (buildPromotedDataCon dc)
            _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) }
 
+tcIfaceKindCon :: IfaceTyCon -> IfL TyCon
+tcIfaceKindCon (IfaceTc name) 
+  = do { thing <- tcIfaceGlobal name
+       ; case thing of    -- A "type constructor" here is a promoted type constructor
+                          --           c.f. Trac #5881
+           ATyCon tc 
+             | isSuperKind (tyConKind tc) -> return tc   -- Mainly just '*' or 'AnyK'
+             | otherwise                  -> return (buildPromotedTyCon tc)
+
+           _ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
+
 tcIfaceCoAxiom :: Name -> IfL CoAxiom
 tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
                          ; return (tyThingCoAxiom thing) }
@@ -1387,7 +1452,7 @@ isSuperIfaceKind _ = False
 
 mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
 mk_iface_tyvar name ifKind
-   = do { kind <- tcIfaceType ifKind
+   = do { kind <- tcIfaceKind ifKind
         ; return (Var.mkTyVar name kind) }
 
 bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index b3f79605a1..b975a20fd1 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1477,8 +1477,8 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     {- Desugar it -}
     -- We use a basically null location for iNTERACTIVE
     let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
-                                      ml_hi_file   = undefined,
-                                      ml_obj_file  = undefined}
+                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",
+                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_hi_file"}
     ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
 
     {- Simplify -}
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 04c858a31c..a9cb1d34b7 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1582,7 +1582,8 @@ flattenedpquals :: { Located [LStmt RdrName] }
                     -- We just had one thing in our "parallel" list so 
                     -- we simply return that thing directly
                     
-                    qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr]
+                    qss -> L1 [L1 $ ParStmt [ParStmtBlock qs undefined noSyntaxExpr | qs <- qss] 
+                                            noSyntaxExpr noSyntaxExpr]
                     -- We actually found some actual parallel lists so
                     -- we wrap them into as a ParStmt
                 }
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index b884d4abde..78566de179 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -544,8 +544,8 @@ methodNamesStmt (LastStmt cmd _)                 = methodNamesLCmd cmd
 methodNamesStmt (ExprStmt cmd _ _ _)             = methodNamesLCmd cmd
 methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
-methodNamesStmt (LetStmt _)                      = emptyFVs
-methodNamesStmt (ParStmt _ _ _ _)                = emptyFVs
+methodNamesStmt (LetStmt {})                     = emptyFVs
+methodNamesStmt (ParStmt {})                     = emptyFVs
 methodNamesStmt (TransStmt {})                   = emptyFVs
    -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error 
    -- here so we just do what's convenient
@@ -767,12 +767,12 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 
 	; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 
-rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside
+rnStmt ctxt (L loc (ParStmt segs _ _)) thing_inside
   = do	{ (mzip_op, fvs1)   <- lookupStmtName ctxt mzipName
         ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
         ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
-	; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
-	; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing)
+	; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
+	; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing)
                  , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
 
 rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
@@ -810,27 +810,26 @@ rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
                                     , trS_ret = return_op, trS_bind = bind_op
                                     , trS_fmap = fmap_op })], thing), all_fvs) }
 
-type ParSeg id = ([LStmt id], [id])	   -- The Names are bound by the Stmts
-
 rnParallelStmts :: forall thing. HsStmtContext Name 
-                -> [ParSeg RdrName]
+                -> SyntaxExpr Name
+                -> [ParStmtBlock RdrName RdrName]
                 -> ([Name] -> RnM (thing, FreeVars))
-                -> RnM (([ParSeg Name], thing), FreeVars)
+                -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
 -- Note [Renaming parallel Stmts]
-rnParallelStmts ctxt segs thing_inside
+rnParallelStmts ctxt return_op segs thing_inside
   = do { orig_lcl_env <- getLocalRdrEnv
        ; rn_segs orig_lcl_env [] segs }
   where
     rn_segs :: LocalRdrEnv
-            -> [Name] -> [ParSeg RdrName]
-            -> RnM (([ParSeg Name], thing), FreeVars)
+            -> [Name] -> [ParStmtBlock RdrName RdrName]
+            -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
     rn_segs _ bndrs_so_far [] 
       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
            ; mapM_ dupErr dups
            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
            ; return (([], thing), fvs) }
 
-    rn_segs env bndrs_so_far ((stmts,_) : segs) 
+    rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) 
       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
                     <- rnStmts ctxt stmts $ \ bndrs ->
                        setLocalRdrEnv env       $ do
@@ -838,7 +837,7 @@ rnParallelStmts ctxt segs thing_inside
 		       ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
                        ; return ((used_bndrs, segs', thing), fvs) }
 		       
-           ; let seg' = (stmts', used_bndrs)
+           ; let seg' = ParStmtBlock stmts' used_bndrs return_op
            ; return ((seg':segs', thing), fvs) }
 
     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
@@ -973,7 +972,7 @@ rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))	-- Flatten Rec inside Rec
     = rn_rec_stmts_lhs fix_env stmts
 
-rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _))	-- Syntactically illegal in mdo
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))	-- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt" (ppr stmt)
   
 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))	-- Syntactically illegal in mdo
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 776e0ccb34..99401faefc 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -432,7 +432,7 @@ badSigErr is_type doc (L loc ty)
   where
     what | is_type   = ptext (sLit "type")
          | otherwise = ptext (sLit "kind")
-    flag | is_type   = ptext (sLit "-XScopedTypeVariable")
+    flag | is_type   = ptext (sLit "-XScopedTypeVariables")
          | otherwise = ptext (sLit "-XKindSignatures")
 \end{code}
 
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 95a473e2ae..e9ec0bea55 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -1252,7 +1252,7 @@ occAnal env (Case scrut bndr ty alts)
   = case occ_anal_scrut scrut alts     of { (scrut_usage, scrut') ->
     case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->
     let
-        alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
+        alts_usage  = foldr combineAltsUsageDetails emptyDetails alts_usage_s
         (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
         total_usage = scrut_usage +++ alts_usage1
     in
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index daadcb7988..0ebde64d6f 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -581,11 +581,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
         -- about to begin, with '1' for the first
       | iteration_no > max_iterations   -- Stop if we've run out of iterations
       = WARN( debugIsOn && (max_iterations > 2)
-            , ptext (sLit "Simplifier baling out after") <+> int max_iterations
-              <+> ptext (sLit "iterations")
-              <+> (brackets $ hsep $ punctuate comma $
-                   map (int . simplCountN) (reverse counts_so_far))
-              <+> ptext (sLit "Size =") <+> ppr (coreBindsStats binds) )
+            , hang (ptext (sLit "Simplifier baling out after") <+> int max_iterations
+                    <+> ptext (sLit "iterations")
+                    <+> (brackets $ hsep $ punctuate comma $
+                         map (int . simplCountN) (reverse counts_so_far)))
+                 2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds)))
 
                 -- Subtract 1 from iteration_no to get the
                 -- number of iterations we actually completed
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7bb4289cd3..87aefbab89 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -24,7 +24,8 @@ module SimplUtils (
 	-- The continuation type
 	SimplCont(..), DupFlag(..), ArgInfo(..),
         isSimplified,
-	contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
+	contIsDupable, contResultType, contInputType,
+        contIsTrivial, contArgs, dropArgs, 
 	pushSimplifiedArgs, countValArgs, countArgs, addArgTo,
 	mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
 	interestingCallContext, 
@@ -54,7 +55,7 @@ import Var
 import Demand
 import SimplMonad
 import Type	hiding( substTy )
-import Coercion hiding( substCo )
+import Coercion hiding( substCo, substTy )
 import DataCon          ( dataConWorkId )
 import VarSet
 import BasicTypes
@@ -96,7 +97,8 @@ Key points:
 
 \begin{code}
 data SimplCont	
-  = Stop		-- An empty context, or hole, []     
+  = Stop		-- An empty context, or <hole>
+        OutType         -- Type of the <hole>
 	CallCtxt	-- True <=> There is something interesting about
 			--          the context, and hence the inliner
 			--	    should be a bit keener (see interestingCallContext)
@@ -104,41 +106,43 @@ data SimplCont
 			--     This is an argument of a function that has RULES
 			--     Inlining the call might allow the rule to fire
 
-  | CoerceIt 		-- C `cast` co
+  | CoerceIt 		-- <hole> `cast` co
 	OutCoercion		-- The coercion simplified
 				-- Invariant: never an identity coercion
 	SimplCont
 
-  | ApplyTo  		-- C arg
+  | ApplyTo  		-- <hole> arg
 	DupFlag			-- See Note [DupFlag invariants]
 	InExpr StaticEnv	-- The argument and its static env
 	SimplCont
 
-  | Select   		-- case C of alts
+  | Select   		-- case <hole> of alts
 	DupFlag 	        -- See Note [DupFlag invariants]
-	InId [InAlt] StaticEnv	-- The case binder, alts, and subst-env
+	InId [InAlt] StaticEnv	-- The case binder, alts type, alts, and subst-env
 	SimplCont
 
   -- The two strict forms have no DupFlag, because we never duplicate them
-  | StrictBind 		-- (\x* \xs. e) C
-	InId [InBndr]		-- let x* = [] in e 	
+  | StrictBind 		        -- (\x* \xs. e) <hole>
+	InId [InBndr]		-- let x* = <hole> in e 	
 	InExpr StaticEnv	--	is a special case 
 	SimplCont	
 
-  | StrictArg 		-- f e1 ..en C
+  | StrictArg 		-- f e1 ..en <hole>
  	ArgInfo		-- Specifies f, e1..en, Whether f has rules, etc
 			--     plus strictness flags for *further* args
         CallCtxt        -- Whether *this* argument position is interesting
 	SimplCont		
 
   | TickIt
-        (Tickish Id)    -- Tick tickish []
+        (Tickish Id)    -- Tick tickish <hole>
         SimplCont
 
 data ArgInfo
   = ArgInfo {
-        ai_fun   :: Id,		-- The function
+        ai_fun   :: OutId,	-- The function
 	ai_args  :: [OutExpr],	-- ...applied to these args (which are in *reverse* order)
+        ai_type  :: OutType,    -- Type of (f a1 ... an)
+
 	ai_rules :: [CoreRule],	-- Rules for this function
 
 	ai_encl :: Bool,	-- Flag saying whether this function 
@@ -154,16 +158,17 @@ data ArgInfo
     }
 
 addArgTo :: ArgInfo -> OutExpr -> ArgInfo
-addArgTo ai arg = ai { ai_args = arg : ai_args ai }
+addArgTo ai arg = ai { ai_args = arg : ai_args ai
+                     , ai_type = applyTypeToArg (ai_type ai) arg  }
 
 instance Outputable SimplCont where
-  ppr (Stop interesting)    	     = ptext (sLit "Stop") <> brackets (ppr interesting)
+  ppr (Stop ty interesting)    	     = ptext (sLit "Stop") <> brackets (ppr interesting) <+> ppr ty
   ppr (ApplyTo dup arg _ cont)       = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
-					  {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
+				       	  {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
   ppr (StrictBind b _ _ _ cont)      = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
   ppr (StrictArg ai _ cont)          = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
   ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ 
-				       (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont 
+				         (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont 
   ppr (CoerceIt co cont)	     = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
   ppr (TickIt t cont)                = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
 
@@ -193,14 +198,14 @@ the following invariants hold
 
 \begin{code}
 -------------------
-mkBoringStop :: SimplCont
-mkBoringStop = Stop BoringCtxt
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty BoringCtxt
 
-mkRhsStop :: SimplCont	-- See Note [RHS of lets] in CoreUnfold
-mkRhsStop = Stop (ArgCtxt False)
+mkRhsStop :: OutType -> SimplCont	-- See Note [RHS of lets] in CoreUnfold
+mkRhsStop ty = Stop ty (ArgCtxt False)
 
-mkLazyArgStop :: CallCtxt -> SimplCont
-mkLazyArgStop cci = Stop cci
+mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
+mkLazyArgStop ty cci = Stop ty cci
 
 -------------------
 contIsRhsOrArg :: SimplCont -> Bool
@@ -226,28 +231,28 @@ contIsTrivial (CoerceIt _ cont)           = contIsTrivial cont
 contIsTrivial _                           = False
 
 -------------------
-contResultType :: SimplEnv -> OutType -> SimplCont -> OutType
-contResultType env ty cont
-  = go cont ty
-  where
-    subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty
-    subst_co se co = SimplEnv.substCo (se `setInScope` env) co
-
-    go (Stop {})                      ty = ty
-    go (CoerceIt co cont)             _  = go cont (pSnd (coercionKind co))
-    go (StrictBind _ bs body se cont) _  = go cont (subst_ty se (exprType (mkLams bs body)))
-    go (StrictArg ai _ cont)          _  = go cont (funResultTy (argInfoResultTy ai))
-    go (Select _ _ alts se cont)      _  = go cont (subst_ty se (coreAltsType alts))
-    go (ApplyTo _ arg se cont)        ty = go cont (apply_to_arg ty arg se)
-    go (TickIt _ cont)                ty = go cont ty
-
-    apply_to_arg ty (Type ty_arg)     se = applyTy ty (subst_ty se ty_arg)
-    apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg)
-    apply_to_arg ty _                 _  = funResultTy ty
-
-argInfoResultTy :: ArgInfo -> OutType
-argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
-  = foldr (\arg fn_ty -> applyTypeToArg fn_ty arg) (idType fun) args
+contResultType :: SimplCont -> OutType
+contResultType (Stop ty _)            = ty
+contResultType (CoerceIt _ k)         = contResultType k
+contResultType (StrictBind _ _ _ _ k) = contResultType k
+contResultType (StrictArg _ _ k)      = contResultType k
+contResultType (Select _ _ _ _ k)     = contResultType k
+contResultType (ApplyTo _ _ _ k)      = contResultType k
+contResultType (TickIt _ k)           = contResultType k
+
+contInputType :: SimplCont -> OutType
+contInputType (Stop ty _)             = ty
+contInputType (CoerceIt co _)         = pFst (coercionKind co)
+contInputType (Select d b _ se _)     = perhapsSubstTy d se (idType b)
+contInputType (StrictBind b _ _ se _) = substTy se (idType b)
+contInputType (StrictArg ai _ _)      = funArgTy (ai_type ai)
+contInputType (ApplyTo d e se k)      = mkFunTy (perhapsSubstTy d se (exprType e)) (contInputType k)
+contInputType (TickIt _ k)            = contInputType k
+
+perhapsSubstTy :: DupFlag -> SimplEnv -> InType -> OutType
+perhapsSubstTy dup_flag se ty 
+  | isSimplified dup_flag = ty
+  | otherwise             = substTy se ty
 
 -------------------
 countValArgs :: SimplCont -> Int
@@ -343,7 +348,7 @@ interestingCallContext cont
 
     interesting (StrictArg _ cci _) = cci
     interesting (StrictBind {})	    = BoringCtxt
-    interesting (Stop cci)   	    = cci
+    interesting (Stop _ cci)  	    = cci
     interesting (TickIt _ cci)      = interesting cci
     interesting (CoerceIt _ cont)   = interesting cont
 	-- If this call is the arg of a strict function, the context
@@ -371,16 +376,19 @@ mkArgInfo :: Id
 
 mkArgInfo fun rules n_val_args call_cont
   | n_val_args < idArity fun		-- Note [Unsaturated functions]
-  = ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules
-            , ai_encl = False
+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
+            , ai_rules = rules, ai_encl = False
 	    , ai_strs = vanilla_stricts 
 	    , ai_discs = vanilla_discounts }
   | otherwise
-  = ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules
+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
+            , ai_rules = rules
             , ai_encl = interestingArgContext rules call_cont
-	    , ai_strs  = add_type_str (idType fun) arg_stricts
+	    , ai_strs  = add_type_str fun_ty arg_stricts
 	    , ai_discs = arg_discounts }
   where
+    fun_ty = idType fun
+
     vanilla_discounts, arg_discounts :: [Int]
     vanilla_discounts = repeat 0
     arg_discounts = case idUnfolding fun of
@@ -466,7 +474,7 @@ interestingArgContext rules call_cont
     go (StrictArg _ cci _) = interesting cci
     go (StrictBind {})	   = False	-- ??
     go (CoerceIt _ c)	   = go c
-    go (Stop cci)          = interesting cci
+    go (Stop _ cci)        = interesting cci
     go (TickIt _ c)        = go c
 
     interesting (ArgCtxt rules) = rules
@@ -1589,14 +1597,14 @@ and similarly in cascade for all the join points!
 mkCase, mkCase1, mkCase2 
    :: DynFlags 
    -> OutExpr -> OutId
-   -> [OutAlt]		-- Alternatives in standard (increasing) order
+   -> OutType -> [OutAlt]		-- Alternatives in standard (increasing) order
    -> SimplM OutExpr
 
 --------------------------------------------------
 --	1. Merge Nested Cases
 --------------------------------------------------
 
-mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
+mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
   | dopt Opt_CaseMerge dflags
   , Case (Var inner_scrut_var) inner_bndr _ inner_alts <- deflt_rhs
   , inner_scrut_var == outer_bndr
@@ -1622,7 +1630,7 @@ mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
 		-- When we merge, we must ensure that e1 takes 
 		-- precedence over e2 as the value for A!  
 
-	; mkCase1 dflags scrut outer_bndr merged_alts
+	; mkCase1 dflags scrut outer_bndr alts_ty merged_alts
 	}
     	-- Warning: don't call mkCase recursively!
     	-- Firstly, there's no point, because inner alts have already had
@@ -1630,13 +1638,13 @@ mkCase dflags scrut outer_bndr ((DEFAULT, _, deflt_rhs) : outer_alts)
     	-- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
     	-- in munge_rhs may put a case into the DEFAULT branch!
 
-mkCase dflags scrut bndr alts = mkCase1 dflags scrut bndr alts
+mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts
 
 --------------------------------------------------
 --	2. Eliminate Identity Case
 --------------------------------------------------
 
-mkCase1 _dflags scrut case_bndr alts	-- Identity case
+mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case
   | all identity_alt alts
   = do { tick (CaseIdentity case_bndr)
        ; return (re_cast scrut rhs1) }
@@ -1665,32 +1673,30 @@ mkCase1 _dflags scrut case_bndr alts	-- Identity case
 	-- 
 	-- Don't worry about nested casts, because the simplifier combines them
 
-    ((_,_,rhs1):_) = alts
-
     re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
     re_cast scrut _             = scrut
 
 --------------------------------------------------
 --	3. Merge Identical Alternatives
 --------------------------------------------------
-mkCase1 dflags scrut case_bndr ((_con1,bndrs1,rhs1) : con_alts)
+mkCase1 dflags scrut case_bndr alts_ty ((_con1,bndrs1,rhs1) : con_alts)
   | all isDeadBinder bndrs1			-- Remember the default 
   , length filtered_alts < length con_alts	-- alternative comes first
 	-- Also Note [Dead binders]
   = do	{ tick (AltMerge case_bndr)
-	; mkCase2 dflags scrut case_bndr alts' }
+	; mkCase2 dflags scrut case_bndr alts_ty alts' }
   where
     alts' = (DEFAULT, [], rhs1) : filtered_alts
     filtered_alts	  = filter keep con_alts
     keep (_con,bndrs,rhs) = not (all isDeadBinder bndrs && rhs `cheapEqExpr` rhs1)
 
-mkCase1 dflags scrut bndr alts = mkCase2 dflags scrut bndr alts
+mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
 
 --------------------------------------------------
 --	Catch-all
 --------------------------------------------------
-mkCase2 _dflags scrut bndr alts 
-  = return (Case scrut bndr (coreAltsType alts) alts)
+mkCase2 _dflags scrut bndr alts_ty alts 
+  = return (Case scrut bndr alts_ty alts)
 \end{code}
 
 Note [Dead binders]
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 335f86a549..56e0bededd 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -24,7 +24,7 @@ import FamInstEnv	( FamInstEnv )
 import Literal		( litIsLifted )
 import Id
 import MkId		( seqId, realWorldPrimId )
-import MkCore		( mkImpossibleExpr )
+import MkCore		( mkImpossibleExpr, castBottomExpr )
 import IdInfo
 import Name		( mkSystemVarName, isExternalName )
 import Coercion hiding  ( substCo, substTy, substCoVar, extendTvSubst )
@@ -339,11 +339,14 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
 			--    f = /\a. \x. g a x  
 			-- should eta-reduce
 
+
         ; (body_env, tvs') <- simplBinders rhs_env tvs
                 -- See Note [Floating and type abstraction] in SimplUtils
 
         -- Simplify the RHS
-        ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
+        ; let   body_out_ty :: OutType
+                body_out_ty = substTy body_env (exprType body)
+        ; (body_env1, body1) <- simplExprF body_env body (mkRhsStop body_out_ty)
         -- ANF-ise a constructor or PAP rhs
         ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
 
@@ -879,7 +882,10 @@ might do the same again.
 
 \begin{code}
 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-simplExpr env expr = simplExprC env expr mkBoringStop
+simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
+  where
+    expr_out_ty :: OutType
+    expr_out_ty = substTy env (exprType expr)
 
 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
         -- Simplify an expression, given a continuation
@@ -941,7 +947,7 @@ simplExprF1 env expr@(Lam {}) cont
     zap b | isTyVar b = b
           | otherwise = zapLamIdInfo b
 
-simplExprF1 env (Case scrut bndr _ alts) cont
+simplExprF1 env (Case scrut bndr alts_ty alts) cont
   | sm_case_case (getMode env)
   =     -- Simplify the scrutinee with a Select continuation
     simplExprF env scrut (Select NoDup bndr alts env cont)
@@ -949,9 +955,11 @@ simplExprF1 env (Case scrut bndr _ alts) cont
   | otherwise
   =     -- If case-of-case is off, simply simplify the case expression
         -- in a vanilla Stop context, and rebuild the result around it
-    do  { case_expr' <- simplExprC env scrut
-                             (Select NoDup bndr alts env mkBoringStop)
+    do  { case_expr' <- simplExprC env scrut 
+                             (Select NoDup bndr alts env (mkBoringStop alts_out_ty))
         ; rebuild env case_expr' cont }
+  where
+    alts_out_ty = substTy env alts_ty
 
 simplExprF1 env (Let (Rec pairs) body) cont
   = do  { env' <- simplRecBndrs env (map fst pairs)
@@ -1035,7 +1043,7 @@ simplTick env tickish expr cont
 
  where
   interesting_cont = case cont of
-                        Select _ _ _ _ _ -> True
+                        Select {} -> True
                         _ -> False
 
   push_tick_inside t expr0
@@ -1105,7 +1113,7 @@ simplTick env tickish expr cont
     where (inc,outc) = splitCont c
   splitCont (CoerceIt co c) = (CoerceIt co inc, outc)
     where (inc,outc) = splitCont c
-  splitCont other = (mkBoringStop, other)
+  splitCont other = (mkBoringStop (contInputType other), other)
 
   getDoneId (DoneId id) = id
   getDoneId (DoneEx e)  = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
@@ -1157,18 +1165,18 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
 -- only the in-scope set and floats should matter
 rebuild env expr cont
   = case cont of
-      Stop {}                      -> return (env, expr)
-      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
-                                         ; simplLam env' bs body cont }
-      ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
-        | isSimplified dup_flag    -> rebuild env (App expr arg) cont
-        | otherwise                -> do { arg' <- simplExpr (se `setInScope` env) arg
-                                         ; rebuild env (App expr arg') cont }
-      TickIt t cont                -> rebuild env (mkTick t expr) cont
+      Stop {}                       -> return (env, expr)
+      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
+                                          ; simplLam env' bs body cont }
+      ApplyTo dup_flag arg se cont  -- See Note [Avoid redundant simplification]
+        | isSimplified dup_flag     -> rebuild env (App expr arg) cont
+        | otherwise                 -> do { arg' <- simplExpr (se `setInScope` env) arg
+                                          ; rebuild env (App expr arg') cont }
+      TickIt t cont                 -> rebuild env (mkTick t expr) cont
 \end{code}
 
 
@@ -1380,7 +1388,7 @@ simplIdF env var cont
 ---------------------------------------------------------
 --      Dealing with a call site
 
-completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
+completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr)
 completeCall env var cont
   = do  {   ------------- Try inlining ----------------
           dflags <- getDynFlags
@@ -1437,21 +1445,17 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
   -- the continuation, leaving just the bottoming expression.  But the
   -- type might not be right, so we may have to add a coerce.
   | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
-  = return (env, mk_coerce res)  -- contination to discard, else we do it
-  where                          -- again and again!
+  = return (env, castBottomExpr res cont_ty)  -- contination to discard, else we do it
+  where                                       -- again and again!
     res     = mkApps (Var fun) (reverse rev_args)
-    res_ty  = exprType res
-    cont_ty = contResultType env res_ty cont
-    co      = mkUnsafeCo res_ty cont_ty
-    mk_coerce expr | cont_ty `eqType` res_ty = expr
-                   | otherwise = mkCast expr co
+    cont_ty = contResultType cont
 
 rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
   = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
                     else simplType (se `setInScope` env) arg_ty
        ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
 
-rebuildCall env info@(ArgInfo { ai_encl = encl_rules
+rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
                               , ai_strs = str:strs, ai_discs = disc:discs })
             (ApplyTo dup_flag arg arg_se cont)
   | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
@@ -1469,7 +1473,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
         -- have to be very careful about bogus strictness through
         -- floating a demanded let.
   = do  { arg' <- simplExprC (arg_se `setInScope` env) arg
-                             (mkLazyArgStop cci)
+                             (mkLazyArgStop (funArgTy fun_ty) cci)
         ; rebuildCall env (addArgTo info' arg') cont }
   where
     info' = info { ai_strs = strs, ai_discs = discs }
@@ -1849,16 +1853,14 @@ reallyRebuildCase env scrut case_bndr alts cont
         -- Simplify the alternatives
         ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
 
-	-- Check for empty alternatives
-	; if null alts' then missingAlt env case_bndr alts cont
-	  else do
-        { dflags <- getDynFlags
-        ; case_expr <- mkCase dflags scrut' case_bndr' alts'
+        ; dflags <- getDynFlags
+        ; let alts_ty' = contResultType dup_cont
+        ; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts'
 
 	-- Notice that rebuild gets the in-scope set from env', not alt_env
 	-- (which in any case is only build in simplAlts)
 	-- The case binder *not* scope over the whole returned case-expression
-	; rebuild env' case_expr nodup_cont } }
+	; rebuild env' case_expr nodup_cont }
 \end{code}
 
 simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
@@ -1949,8 +1951,7 @@ simplAlts :: SimplEnv
 -- The returned alternatives can be empty, none are possible
 
 simplAlts env scrut case_bndr alts cont'
-  = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $
-    do  { let env0 = zapFloats env
+  = do  { let env0 = zapFloats env
 
         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
 
@@ -1965,7 +1966,8 @@ simplAlts env scrut case_bndr alts cont'
 	; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing }
         ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
                              imposs_deflt_cons case_bndr' cont') in_alts
-        ; return (scrut', case_bndr', alts') }
+        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
+          return (scrut', case_bndr', alts') }
 
 
 ------------------------------------
@@ -2182,11 +2184,9 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp
 		-- an inner case has no accessible alternatives before 
 		-- it "sees" that the entire branch of an outer case is 
 		-- inaccessible.  So we simply put an error case here instead.
-missingAlt env case_bndr alts cont
+missingAlt env case_bndr _ cont
   = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
-    return (env, mkImpossibleExpr res_ty)
-  where
-    res_ty = contResultType env (substTy env (coreAltsType alts)) cont
+    return (env, mkImpossibleExpr (contResultType cont))
 \end{code}
 
 
@@ -2214,7 +2214,7 @@ prepareCaseCont :: SimplEnv
 
 prepareCaseCont env alts cont 
   | many_alts alts = mkDupableCont env cont 
-  | otherwise      = return (env, cont, mkBoringStop)
+  | otherwise      = return (env, cont, mkBoringStop (contResultType cont))
   where
     many_alts :: [InAlt] -> Bool  -- True iff strictly > 1 non-bottom alternative
     many_alts []  = False   	  -- See Note [Bottom alternatives]
@@ -2243,7 +2243,7 @@ mkDupableCont :: SimplEnv -> SimplCont
 
 mkDupableCont env cont
   | contIsDupable cont
-  = return (env, cont, mkBoringStop)
+  = return (env, cont, mkBoringStop (contResultType cont))
 
 mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
 
@@ -2253,10 +2253,10 @@ mkDupableCont env (CoerceIt ty cont)
 
 -- Duplicating ticks for now, not sure if this is good or not
 mkDupableCont env cont@(TickIt{})
-  = return (env, mkBoringStop, cont)
+  = return (env, mkBoringStop (contInputType cont), cont)
 
 mkDupableCont env cont@(StrictBind {})
-  =  return (env, mkBoringStop, cont)
+  =  return (env, mkBoringStop (contInputType cont), cont)
         -- See Note [Duplicating StrictBind]
 
 mkDupableCont env (StrictArg info cci cont)
@@ -2283,7 +2283,7 @@ mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
   | all isDeadBinder bs  -- InIds
     && not (isUnLiftedType (idType case_bndr))
     -- Note [Single-alternative-unlifted]
-  = return (env, mkBoringStop, cont)
+  = return (env, mkBoringStop (contInputType cont), cont)
 
 mkDupableCont env (Select _ case_bndr alts se cont)
   =     -- e.g.         (case [...hole...] of { pi -> ei })
@@ -2300,6 +2300,7 @@ mkDupableCont env (Select _ case_bndr alts se cont)
 		-- And this is important: see Note [Fusing case continuations]
 
         ; let alt_env = se `setInScope` env'
+
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
         ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
         -- Safe to say that there are no handled-cons for the DEFAULT case
@@ -2316,7 +2317,8 @@ mkDupableCont env (Select _ case_bndr alts se cont)
 
         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
         ; return (env'',  -- Note [Duplicated env]
-                  Select OkToDup case_bndr' alts'' (zapSubstEnv env'') mkBoringStop,
+                  Select OkToDup case_bndr' alts'' (zapSubstEnv env'') 
+                         (mkBoringStop (contInputType nodup_cont)),
                   nodup_cont) }
 
 
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index d2c07bcc1b..a65d46e339 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -1023,7 +1023,7 @@ scExpr' env (Case scrut b ty alts)
   where
     sc_con_app con args scrut' 	-- Known constructor; simplify
 	= do { let (_, bs, rhs) = findAlt con alts
-	       	   	          `orElse` (DEFAULT, [], mkImpossibleExpr (coreAltsType alts))
+	       	   	          `orElse` (DEFAULT, [], mkImpossibleExpr ty)
 		   alt_env'  = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
 	     ; scExpr alt_env' rhs }
 				
@@ -1034,7 +1034,7 @@ scExpr' env (Case scrut b ty alts)
 	  ; (alt_usgs, alt_occs, alts')
 		<- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
 
-	  ; let scrut_occ  = foldr1 combineOcc alt_occs	-- Never empty
+	  ; let scrut_occ  = foldr combineOcc NoOcc alt_occs
 		scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
 	  	-- The combined usage of the scrutinee is given
 	  	-- by scrut_occ, which is passed to scScrut, which
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 321deb866a..6c80f8fbde 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -1037,12 +1037,12 @@ specCalls subst rules_for_me calls_for_me fn rhs
   = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for") 
                                  <+> ppr fn $$ _trace_doc )
 	  -- Note [Specialisation shape]
-    -- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $
+    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
     return ([], [], emptyUDs)
   where
-    _trace_doc = vcat [ ppr rhs_tyvars, ppr n_tyvars
-                      , ppr rhs_ids, ppr n_dicts
-                      , ppr (idInlineActivation fn) ]
+    _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars
+                     , ppr rhs_ids, ppr n_dicts
+                     , ppr (idInlineActivation fn) ]
 
     fn_type	       = idType fn
     fn_arity	       = idArity fn
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 71bdfe97c9..c4f289c68e 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -363,6 +363,18 @@ coreToStgExpr (Cast expr _)
 
 -- Cases require a little more real work.
 
+coreToStgExpr (Case scrut _ _ []) 
+  = coreToStgExpr scrut   
+    -- See Note [Empty case alternatives] in CoreSyn If the case
+    -- alternatives are empty, the scrutinee must diverge or raise an
+    -- exception, so we can just dive into it.
+    --
+    -- Of course this may seg-fault if the scrutinee *does* return.  A
+    -- belt-and-braces approach would be to move this case into the
+    -- code generator, and put a return point anyway that calls a
+    -- runtime system error function.
+        
+
 coreToStgExpr (Case scrut bndr _ alts) = do
     (alts2, alts_fvs, alts_escs)
        <- extendVarEnvLne [(bndr, LambdaBound)] $ do
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 167debfb55..b85c107bea 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -277,7 +277,7 @@ dmdAnal env dmd (Case scrut case_bndr ty alts)
   = let
 	(alt_tys, alts')        = mapAndUnzip (dmdAnalAlt env dmd) alts
 	(scrut_ty, scrut')      = dmdAnal env evalDmd scrut
-	(alt_ty, case_bndr')	= annotateBndr (foldr1 lubType alt_tys) case_bndr
+	(alt_ty, case_bndr')	= annotateBndr (foldr lubType botDmdType alt_tys) case_bndr
         res_ty                  = alt_ty `bothType` scrut_ty
     in
 --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index d8ba828d9a..0b4364b7ee 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -83,10 +83,11 @@ emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
 emitWanteds origin theta = mapM (emitWanted origin) theta
 
 emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
-emitWanted origin pred = do { loc <- getCtLoc origin
-                            ; ev  <- newWantedEvVar pred
-                            ; emitFlat (mkNonCanonical (Wanted loc ev))
-                            ; return ev }
+emitWanted origin pred 
+  = do { loc <- getCtLoc origin
+       ; ev  <- newWantedEvVar pred
+       ; emitFlat (mkNonCanonical (Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev }))
+       ; return ev }
 
 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
 -- Used when Name is the wired-in name for a wired-in class method,
@@ -530,7 +531,7 @@ 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_flavor = fl })           = tyVarsOfType (ctFlavPred fl)
+tyVarsOfCt (CNonCanonical { cc_ev = fl })           = tyVarsOfType (ctEvPred fl)
 
 tyVarsOfCDict :: Ct -> TcTyVarSet 
 tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
@@ -564,24 +565,22 @@ tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
 ---------------- Tidying -------------------------
 
 tidyCt :: TidyEnv -> Ct -> Ct
+-- Used only in error reporting
 -- Also converts it to non-canonical
 tidyCt env ct 
-  = CNonCanonical { cc_flavor = tidy_flavor env (cc_flavor ct)
+  = CNonCanonical { cc_ev = tidy_flavor env (cc_ev ct)
                   , cc_depth  = cc_depth ct } 
-  where tidy_flavor :: TidyEnv -> CtFlavor -> CtFlavor
-        tidy_flavor env (Given { flav_gloc = gloc, flav_evar = evar })
-          = Given { flav_gloc = tidyGivenLoc env gloc
-                  , flav_evar = tidyEvVar env evar }
-        tidy_flavor env (Solved { flav_gloc = gloc
-                                , flav_evar = evar }) 
-          = Solved { flav_gloc  = tidyGivenLoc env gloc
-                   , flav_evar = tidyEvVar env evar }
-        tidy_flavor env (Wanted { flav_wloc = wloc
-                                , flav_evar = evar })
-          = Wanted { flav_wloc = wloc -- Interesting: no tidying needed?
-                   , flav_evar = tidyEvVar env evar }
-        tidy_flavor env (Derived { flav_wloc = wloc, flav_der_pty = pty })
-          = Derived { flav_wloc = wloc, flav_der_pty = tidyType env pty }
+  where 
+    tidy_flavor :: TidyEnv -> CtEvidence -> CtEvidence
+     -- NB: we do not tidy the ctev_evtm/var field because we don't 
+     --     show it in error messages
+    tidy_flavor env ctev@(Given { ctev_gloc = gloc, ctev_pred = pred })
+      = ctev { ctev_gloc = tidyGivenLoc env gloc
+             , ctev_pred = tidyType env pred }
+    tidy_flavor env ctev@(Wanted { ctev_pred = pred })
+      = ctev { ctev_pred = tidyType env pred }
+    tidy_flavor env ctev@(Derived { ctev_pred = pred })
+      = ctev { ctev_pred = tidyType env pred }
 
 tidyEvVar :: TidyEnv -> EvVar -> EvVar
 tidyEvVar env var = setVarType var (tidyType env (varType var))
@@ -604,6 +603,10 @@ tidySkolemInfo env (UnifyForAllSkol skol_tvs ty)
 tidySkolemInfo _   info            = info
 
 ---------------- Substitution -------------------------
+-- This is used only in TcSimpify, for substituations that are *also* 
+-- reflected in the unification variables.  So we don't substitute
+-- in the evidence.
+
 substCt :: TvSubst -> Ct -> Ct 
 -- Conservatively converts it to non-canonical:
 -- Postcondition: if the constraint does not get rewritten
@@ -611,9 +614,9 @@ substCt subst ct
   | pty <- ctPred ct
   , sty <- substTy subst pty 
   = if sty `eqType` pty then 
-        ct { cc_flavor = substFlavor subst (cc_flavor ct) }
+        ct { cc_ev = substFlavor subst (cc_ev ct) }
     else 
-        CNonCanonical { cc_flavor = substFlavor subst (cc_flavor ct)
+        CNonCanonical { cc_ev = substFlavor subst (cc_ev ct)
                       , cc_depth  = cc_depth ct }
 
 substWC :: TvSubst -> WantedConstraints -> WantedConstraints
@@ -637,21 +640,16 @@ substImplication subst implic@(Implic { ic_skols = tvs
 substEvVar :: TvSubst -> EvVar -> EvVar
 substEvVar subst var = setVarType var (substTy subst (varType var))
 
-substFlavor :: TvSubst -> CtFlavor -> CtFlavor
-substFlavor subst (Given { flav_gloc = gloc, flav_evar = evar })
-  = Given { flav_gloc = substGivenLoc subst gloc
-          , flav_evar = substEvVar subst evar }
-substFlavor subst (Solved { flav_gloc = gloc, flav_evar = evar })
-  = Solved { flav_gloc = substGivenLoc subst gloc
-           , flav_evar = substEvVar subst evar }
-
-substFlavor subst (Wanted { flav_wloc = wloc, flav_evar = evar })
-  = Wanted { flav_wloc  = wloc
-           , flav_evar = substEvVar subst evar }
-
-substFlavor subst (Derived { flav_wloc = wloc, flav_der_pty = pty })
-  = Derived { flav_wloc = wloc
-            , flav_der_pty = substTy subst pty }
+substFlavor :: TvSubst -> CtEvidence -> CtEvidence
+substFlavor subst ctev@(Given { ctev_gloc = gloc, ctev_pred = pred })
+  = ctev { ctev_gloc = substGivenLoc subst gloc
+          , ctev_pred = substTy subst pred }
+
+substFlavor subst ctev@(Wanted { ctev_pred = pred })
+  = ctev  { ctev_pred = substTy subst pred }
+
+substFlavor subst ctev@(Derived { ctev_pred = pty })
+  = ctev { ctev_pred = substTy subst pty }
 
 substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
 substGivenLoc subst (CtLoc skol span ctxt) 
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 1cc97de8d3..e6e07576d2 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -379,7 +379,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
         -- Set up main recover; take advantage of any type sigs
 
     { traceTc "------------------------------------------------" empty
-    ; traceTc "Bindings for" (ppr binder_names)
+    ; traceTc "Bindings for {" (ppr binder_names)
 
 --    -- Instantiate the polytypes of any binders that have signatures
 --    -- (as determined by sig_fn), returning a TcSigInfo for each
@@ -390,7 +390,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
     ; let plan = decideGeneralisationPlan dflags type_env 
                          binder_names bind_list sig_fn
     ; traceTc "Generalisation plan" (ppr plan)
-    ; result@(_, poly_ids, _) <- case plan of
+    ; result@(tc_binds, poly_ids, _) <- case plan of
          NoGen          -> tcPolyNoGen sig_fn prag_fn rec_tc bind_list
          InferGen mn cl -> tcPolyInfer mn cl sig_fn prag_fn rec_tc bind_list
          CheckGen sig   -> tcPolyCheck sig prag_fn rec_tc bind_list
@@ -398,7 +398,10 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
         -- Check whether strict bindings are ok
         -- These must be non-recursive etc, and are not generalised
         -- They desugar to a case expression in the end
-    ; checkStrictBinds top_lvl rec_group bind_list poly_ids
+    ; checkStrictBinds top_lvl rec_group bind_list tc_binds poly_ids
+    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
+                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
+                                          ])
 
     ; return result }
   where
@@ -1242,21 +1245,32 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
 
 -------------------
 checkStrictBinds :: TopLevelFlag -> RecFlag
-                 -> [LHsBind Name] -> [Id]
+                 -> [LHsBind Name]
+                 -> LHsBinds TcId -> [Id]
                  -> TcM ()
 -- Check that non-overloaded unlifted bindings are
 --      a) non-recursive,
 --      b) not top level, 
 --      c) not a multiple-binding group (more or less implied by (a))
 
-checkStrictBinds top_lvl rec_group binds poly_ids
+checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
   | unlifted || bang_pat
   = do  { checkTc (isNotTopLevel top_lvl)
-                  (strictBindErr "Top-level" unlifted binds)
+                  (strictBindErr "Top-level" unlifted orig_binds)
         ; checkTc (isNonRec rec_group)
-                  (strictBindErr "Recursive" unlifted binds)
-        ; checkTc (isSingleton binds)
-                  (strictBindErr "Multiple" unlifted binds)
+                  (strictBindErr "Recursive" unlifted orig_binds)
+
+        ; checkTc (all is_monomorphic (bagToList tc_binds))
+                  (polyBindErr orig_binds)
+            -- data Ptr a = Ptr Addr#
+            -- f x = let p@(Ptr y) = ... in ...
+            -- Here the binding for 'p' is polymorphic, but does 
+            -- not mix with an unlifted binding for 'y'.  You should
+            -- use a bang pattern.  Trac #6078.
+        
+        ; checkTc (isSingleton orig_binds)
+                  (strictBindErr "Multiple" unlifted orig_binds)
+
         -- This should be a checkTc, not a warnTc, but as of GHC 6.11
         -- the versions of alex and happy available have non-conforming
         -- templates, so the GHC build fails if it's an error:
@@ -1267,31 +1281,40 @@ checkStrictBinds top_lvl rec_group binds poly_ids
                  -- Warn about this, but not about
                  --      x# = 4# +# 1#
                  --      (# a, b #) = ...
-                 (unliftedMustBeBang binds) }
+                 (unliftedMustBeBang orig_binds) }
   | otherwise
-  = return ()
+  = traceTc "csb2" (ppr poly_ids) >>
+    return ()
   where
     unlifted    = any is_unlifted poly_ids
-    bang_pat    = any (isBangHsBind . unLoc) binds
-    lifted_pat  = any (isLiftedPatBind . unLoc) binds
+    bang_pat    = any (isBangHsBind    . unLoc) orig_binds
+    lifted_pat  = any (isLiftedPatBind . unLoc) orig_binds
+
     is_unlifted id = case tcSplitForAllTys (idType id) of
                        (_, rho) -> isUnLiftedType rho
 
+    is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
+                     = null tvs && null evs
+    is_monomorphic _ = True
+
 unliftedMustBeBang :: [LHsBind Name] -> SDoc
 unliftedMustBeBang binds
   = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
-       2 (pprBindList binds)
+       2 (vcat (map ppr binds))
+
+polyBindErr :: [LHsBind Name] -> SDoc
+polyBindErr binds
+  = hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
+       2 (vcat [vcat (map ppr binds), 
+                ptext (sLit "Probable fix: use a bang pattern")])
 
 strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
 strictBindErr flavour unlifted binds
   = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 
-       2 (pprBindList binds)
+       2 (vcat (map ppr binds))
   where
     msg | unlifted  = ptext (sLit "bindings for unlifted types")
         | otherwise = ptext (sLit "bang-pattern bindings")
-
-pprBindList :: [LHsBind Name] -> SDoc
-pprBindList binds = vcat (map ppr binds)
 \end{code}
 
 
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index d293f0ea3b..2e87c9e2f2 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -173,26 +173,26 @@ EvBinds, so we are again good.
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 canonicalize :: Ct -> TcS StopOrContinue
-canonicalize ct@(CNonCanonical { cc_flavor = fl, cc_depth  = d })
+canonicalize ct@(CNonCanonical { cc_ev = fl, cc_depth  = d })
   = do { traceTcS "canonicalize (non-canonical)" (ppr ct)
        ; {-# SCC "canEvVar" #-}
          canEvVar d fl (classifyPredType (ctPred ct)) }
 
 canonicalize (CDictCan { cc_depth  = d
-                       , cc_flavor = fl
+                       , cc_ev = fl
                        , cc_class  = cls
                        , cc_tyargs = xis })
   = {-# SCC "canClass" #-}
     canClass d fl cls xis -- Do not add any superclasses
 canonicalize (CTyEqCan { cc_depth  = d
-                       , cc_flavor = fl
+                       , cc_ev = fl
                        , cc_tyvar  = tv
                        , cc_rhs    = xi })
   = {-# SCC "canEqLeafTyVarLeftRec" #-}
     canEqLeafTyVarLeftRec d fl tv xi
 
 canonicalize (CFunEqCan { cc_depth = d
-                        , cc_flavor = fl
+                        , cc_ev = fl
                         , cc_fun    = fn
                         , cc_tyargs = xis1
                         , cc_rhs    = xi2 })
@@ -200,18 +200,18 @@ canonicalize (CFunEqCan { cc_depth = d
     canEqLeafFunEqLeftRec d fl (fn,xis1) xi2
 
 canonicalize (CIPCan { cc_depth = d
-                     , cc_flavor = fl
+                     , cc_ev = fl
                      , cc_ip_nm  = nm
                      , cc_ip_ty  = xi })
   = canIP d fl nm xi
-canonicalize (CIrredEvCan { cc_flavor = fl
+canonicalize (CIrredEvCan { cc_ev = fl
                           , cc_depth = d
                           , cc_ty = xi })
   = canIrred d fl xi
 
 
 canEvVar :: SubGoalDepth 
-         -> CtFlavor 
+         -> CtEvidence 
          -> PredTree 
          -> TcS StopOrContinue
 -- Called only for non-canonical EvVars 
@@ -233,15 +233,16 @@ canEvVar d fl pred_classifier
 
 \begin{code}
 canTuple :: SubGoalDepth -- Depth 
-         -> CtFlavor -> [PredType] -> TcS StopOrContinue
+         -> CtEvidence -> [PredType] -> TcS StopOrContinue
 canTuple d fl tys
   = do { traceTcS "can_pred" (text "TuplePred!")
        ; let xcomp = EvTupleMk
              xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..]             
-       ; xCtFlavor fl tys (XEvTerm xcomp xdecomp) what_next }
-  where what_next fls  = mapM_ add_to_work fls >> return Stop
-        add_to_work fl = addToWork $ canEvVar d fl (classifyPredType (ctFlavPred fl))
-        
+       ; ctevs <- xCtFlavor fl tys (XEvTerm xcomp xdecomp)
+       ; mapM_ add_to_work ctevs
+       ; return Stop }
+  where
+    add_to_work fl = addToWork $ canEvVar d fl (classifyPredType (ctEvPred fl))
 \end{code}
 
 
@@ -253,7 +254,7 @@ canTuple d fl tys
 
 \begin{code}
 canIP :: SubGoalDepth -- Depth 
-      -> CtFlavor
+      -> CtEvidence
       -> IPName Name -> Type -> TcS StopOrContinue
 -- Precondition: EvVar is implicit parameter evidence
 canIP d fl nm ty
@@ -264,7 +265,7 @@ canIP d fl nm ty
        ; mb <- rewriteCtFlavor fl xi co 
        ; case mb of
             Just new_fl -> let IPPred _ xi_in = classifyPredType xi
-                           in continueWith $ CIPCan { cc_flavor = new_fl
+                           in continueWith $ CIPCan { cc_ev = new_fl
                                                     , cc_ip_nm = nm, cc_ip_ty = xi_in
                                                     , cc_depth = d }
             Nothing -> return Stop }
@@ -291,7 +292,7 @@ flattened in the first place to facilitate comparing them.)
 \begin{code}
 canClass, canClassNC 
    :: SubGoalDepth -- Depth
-   -> CtFlavor  
+   -> CtEvidence  
    -> Class -> [Type] -> TcS StopOrContinue
 -- Precondition: EvVar is class evidence 
 
@@ -314,14 +315,14 @@ canClass d fl cls tys
 
        ; case mb of
            Just new_fl -> 
-             let (ClassPred cls xis_for_dict) = classifyPredType (ctFlavPred new_fl)
+             let (ClassPred cls xis_for_dict) = classifyPredType (ctEvPred new_fl)
              in continueWith $ 
-                CDictCan { cc_flavor = new_fl
+                CDictCan { cc_ev = new_fl
                          , cc_tyargs = xis_for_dict, cc_class = cls, cc_depth = d }
            Nothing -> return Stop }
 
 emitSuperclasses :: Ct -> TcS StopOrContinue
-emitSuperclasses ct@(CDictCan { cc_depth = d, cc_flavor = fl
+emitSuperclasses ct@(CDictCan { cc_depth = d, cc_ev = fl
                               , 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. 
@@ -399,20 +400,19 @@ happen.
 \begin{code}
 
 newSCWorkFromFlavored :: SubGoalDepth -- Depth
-                      -> CtFlavor -> Class -> [Xi] -> TcS ()
+                      -> CtEvidence -> Class -> [Xi] -> TcS ()
 -- Returns superclasses, see Note [Adding superclasses]
 newSCWorkFromFlavored d flavor cls xis 
   | isDerived flavor 
   = return ()  -- Deriveds don't yield more superclasses because we will
                -- add them transitively in the case of wanteds. 
-  | isSolved flavor
-  = return ()
     
   | isGiven flavor 
   = do { let sc_theta = immSuperClasses cls xis 
              xev = XEvTerm { ev_comp = panic "Can't compose for given!" 
-                           , ev_decomp = \x->zipWith (\_ i->EvSuperClass x i) sc_theta [0..] }
-       ; xCtFlavor flavor sc_theta xev (emit_sc_flavs d) }
+                           , ev_decomp = \x -> zipWith (\_ i -> EvSuperClass x i) sc_theta [0..] }
+       ; ctevs <- xCtFlavor flavor sc_theta xev
+       ; emit_sc_flavs d ctevs }
 
   | isEmptyVarSet (tyVarsOfTypes xis)
   = return () -- Wanteds/Derived with no variables yield no deriveds.
@@ -422,15 +422,17 @@ newSCWorkFromFlavored d flavor cls xis
   = do { let sc_rec_theta = transSuperClasses cls xis 
              impr_theta   = filter is_improvement_pty sc_rec_theta              
              xev = panic "Derived's are not supposed to transform evidence!" 
-       ; xCtFlavor (Derived (flav_wloc flavor) (ctFlavPred flavor)) impr_theta xev $ 
-         emit_sc_flavs d }
+             der_ev = Derived { ctev_wloc = ctev_wloc flavor, ctev_pred = ctev_pred flavor }
+       ; ctevs <- xCtFlavor der_ev impr_theta xev
+       ; emit_sc_flavs d ctevs }
 
-emit_sc_flavs :: SubGoalDepth -> [CtFlavor] -> TcS ()
+emit_sc_flavs :: SubGoalDepth -> [CtEvidence] -> TcS ()
 emit_sc_flavs d fls 
   = do { traceTcS "newSCWorkFromFlavored" $
          text "Emitting superclass work:" <+> ppr sc_cts
        ; updWorkListTcS $ appendWorkListCt sc_cts }
-  where sc_cts = map (\fl -> CNonCanonical { cc_flavor = fl, cc_depth  = d }) fls
+  where 
+    sc_cts = map (\fl -> CNonCanonical { cc_ev = fl, cc_depth  = d }) fls
 
 is_improvement_pty :: PredType -> Bool 
 -- Either it's an equality, or has some functional dependency
@@ -454,7 +456,7 @@ is_improvement_pty ty = go (classifyPredType ty)
 
 \begin{code}
 canIrred :: SubGoalDepth -- Depth
-         -> CtFlavor -> TcType -> TcS StopOrContinue
+         -> CtEvidence -> TcType -> TcS StopOrContinue
 -- Precondition: ty not a tuple and no other evidence form
 canIrred d fl ty 
   = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) 
@@ -468,9 +470,9 @@ canIrred d fl ty
              Just new_fl 
                | no_flattening
                  -> continueWith $
-                    CIrredEvCan { cc_flavor = new_fl, cc_ty = xi, cc_depth = d }
+                    CIrredEvCan { cc_ev = new_fl, cc_ty = xi, cc_depth = d }
                | otherwise
-                 -> canEvVar d new_fl (classifyPredType (ctFlavPred new_fl))
+                 -> canEvVar d new_fl (classifyPredType (ctEvPred new_fl))
              Nothing -> return Stop }
 
 \end{code}
@@ -529,7 +531,7 @@ data FlattenMode = FMSubstOnly
 -- Flatten a bunch of types all at once.
 flattenMany :: SubGoalDepth -- Depth
             -> FlattenMode
-            -> CtFlavor -> [Type] -> TcS ([Xi], [TcCoercion])
+            -> CtEvidence -> [Type] -> TcS ([Xi], [TcCoercion])
 -- Coercions :: Xi ~ Type 
 -- Returns True iff (no flattening happened)
 -- NB: The EvVar inside the flavor is unused, we merely want Given/Solved/Derived/Wanted info
@@ -546,7 +548,7 @@ flattenMany d f ctxt tys
 -- constraints.  See Note [Flattening] for more detail.
 flatten :: SubGoalDepth -- Depth
         -> FlattenMode 
-        -> CtFlavor -> TcType -> TcS (Xi, TcCoercion)
+        -> CtEvidence -> TcType -> TcS (Xi, TcCoercion)
 -- Postcondition: Coercion :: Xi ~ TcType
 flatten d f ctxt ty 
   | Just ty' <- tcView ty
@@ -595,7 +597,8 @@ flatten d f fl (TyConApp tc tys)
                  do { flat_cache <- getFlatCache
                     ; case lookupTM fam_ty flat_cache of
                         Just ct 
-                          | cc_flavor ct `canRewrite` fl 
+                          | let ctev = cc_ev ct
+                          , ctev `canRewrite` fl 
                           -> -- You may think that we can just return (cc_rhs ct) but not so. 
                              --            return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) 
                              -- The cached constraint resides in the cache so we have to flatten 
@@ -606,42 +609,42 @@ flatten d f fl (TyConApp tc tys)
                              -- For now I say we don't keep it fully rewritten.
                             do { traceTcS "flatten/flat-cache hit" $ ppr ct
                                ; let rhs_xi = cc_rhs ct
-                               ; (flat_rhs_xi,co) <- flatten (cc_depth ct) f (cc_flavor ct) rhs_xi
-                               ; let final_co = mkTcCoVarCo (ctId ct) `mkTcTransCo` (mkTcSymCo co)
+                               ; (flat_rhs_xi,co) <- flatten (cc_depth ct) f ctev rhs_xi
+                               ; let final_co = evTermCoercion (ctEvTerm ctev)
+                                                `mkTcTransCo` mkTcSymCo co
                                ; return (final_co, flat_rhs_xi,[]) }
                           
-                        _ | isGivenOrSolved fl -- Given or Solved: make new flatten skolem
+                        _ | isGiven fl -- Given: make new flatten skolem
                           -> do { traceTcS "flatten/flat-cache miss" $ empty 
                                 ; rhs_xi_var <- newFlattenSkolemTy fam_ty
-                                ; mg <- newGivenEvVar (mkTcEqPred fam_ty rhs_xi_var) 
-                                                      (EvCoercion (mkTcReflCo fam_ty)) 
-                                ; case mg of 
-                                   Fresh eqv -> 
-                                     do { let new_fl = Given (flav_gloc fl) eqv
-                                              ct = CFunEqCan { cc_flavor = new_fl
-                                                             , cc_fun    = tc 
-                                                             , cc_tyargs = xi_args 
-                                                             , cc_rhs    = rhs_xi_var 
-                                                             , cc_depth  = d }
-                                              -- Update the flat cache
-                                        ; updFlatCache ct
-                                        ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) }
-                                   Cached {} -> panic "flatten TyConApp, var must be fresh!" }
+                                ; let co = mkTcReflCo fam_ty
+                                      new_fl = Given { ctev_gloc = ctev_gloc fl
+                                                     , ctev_pred = mkTcEqPred fam_ty rhs_xi_var
+                                                     , ctev_evtm = EvCoercion co }
+                                      ct = CFunEqCan { cc_ev = new_fl
+                                                     , cc_fun    = tc 
+                                                     , cc_tyargs = xi_args 
+                                                     , cc_rhs    = rhs_xi_var 
+                                                     , cc_depth  = d }
+                                      -- Update the flat cache
+                                ; updFlatCache ct
+                                ; return (co, rhs_xi_var, [ct]) }
                          | otherwise -- Wanted or Derived: make new unification variable
                          -> do { traceTcS "flatten/flat-cache miss" $ empty 
                                ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty)
-                               ; mw <- newWantedEvVar (mkTcEqPred fam_ty rhs_xi_var)
+                               ; let pred = mkTcEqPred fam_ty rhs_xi_var
+                                     wloc = ctev_wloc fl
+                               ; mw <- newWantedEvVar wloc pred
                                ; case mw of
-                                   Fresh eqv -> 
-                                     do { let new_fl = Wanted (flav_wloc fl) eqv
-                                              ct = CFunEqCan { cc_flavor = new_fl
+                                   Fresh ctev -> 
+                                     do { let ct = CFunEqCan { cc_ev = ctev
                                                              , cc_fun = tc
                                                              , cc_tyargs = xi_args
                                                              , cc_rhs    = rhs_xi_var 
                                                              , cc_depth  = d }
                                           -- Update the flat cache: just an optimisation!
                                         ; updFlatCache ct
-                                        ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) }
+                                        ; return (evTermCoercion (ctEvTerm ctev), rhs_xi_var, [ct]) }
                                    Cached {} -> panic "flatten TyConApp, var must be fresh!" } 
                     }
                   -- Emit the flat constraints
@@ -691,7 +694,7 @@ flatten d _f ctxt ty@(ForAllTy {})
 \begin{code}
 flattenTyVar :: SubGoalDepth 
              -> FlattenMode 
-             -> CtFlavor -> TcTyVar -> TcS (Xi, TcCoercion)
+             -> CtEvidence -> TcTyVar -> TcS (Xi, TcCoercion)
 -- "Flattening" a type variable means to apply the substitution to it
 flattenTyVar d f ctxt tv
   = do { ieqs <- getInertEqs
@@ -709,13 +712,15 @@ flattenTyVar d f ctxt tv
            Just (co,ty) -> 
                do { (ty_final,co') <- flatten d f ctxt ty
                   ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } }  
-  where tv_eq_subst subst tv
-          | Just ct <- lookupVarEnv subst tv
-          , cc_flavor ct `canRewrite` ctxt
-          = Just (mkTcCoVarCo (ctId ct),cc_rhs ct)
-                 -- NB: even if ct is Derived we are not going to 
-                 -- touch the actual coercion so we are fine. 
-          | otherwise = Nothing
+  where 
+    tv_eq_subst subst tv
+       | Just ct <- lookupVarEnv subst tv
+       , let ctev = cc_ev ct
+       , ctev `canRewrite` ctxt
+       = Just (evTermCoercion (ctEvTerm ctev), cc_rhs ct)
+              -- NB: even if ct is Derived we are not going to 
+              -- touch the actual coercion so we are fine. 
+       | otherwise = Nothing
 \end{code}
 
 Note [Non-idempotent inert substitution]
@@ -765,13 +770,13 @@ addToWork tcs_action = tcs_action >>= stop_or_emit
 
 \begin{code}
 canEqEvVarsCreated :: SubGoalDepth
-                   -> [CtFlavor] -> TcS StopOrContinue
+                   -> [CtEvidence] -> TcS StopOrContinue
 canEqEvVarsCreated _d [] = return Stop
 canEqEvVarsCreated d (quad:quads) 
   = mapM_ (addToWork . do_quad) quads >> do_quad quad
            -- Add all but one to the work list
            -- and return the first (if any) for futher processing
-  where do_quad fl = let EqPred ty1 ty2 = classifyPredType $ ctFlavPred fl
+  where do_quad fl = let EqPred ty1 ty2 = classifyPredType $ ctEvPred fl
                      in canEqNC d fl ty1 ty2
           -- Note the "NC": these are fresh equalities so we must be
           -- careful to add their kind constraints
@@ -779,7 +784,7 @@ canEqEvVarsCreated d (quad:quads)
 -------------------------
 canEqNC, canEq 
   :: SubGoalDepth 
-  -> CtFlavor 
+  -> CtEvidence 
   -> Type -> Type -> TcS StopOrContinue
 
 canEqNC d fl ty1 ty2
@@ -790,7 +795,7 @@ canEq _d fl ty1 ty2
   | eqType ty1 ty2	-- Dealing with equality here avoids
     	     	 	-- later spurious occurs checks for a~a
   = if isWanted fl then
-      setEvBind (flav_evar fl) (EvCoercion (mkTcReflCo ty1)) >> return Stop
+      setEvBind (ctev_evar fl) (EvCoercion (mkTcReflCo ty1)) >> return Stop
     else
       return Stop
 
@@ -823,11 +828,11 @@ canEq d fl ty1 ty2
     -- Fail straight away for better error messages
     then canEqFailure d fl
     else
-      let xcomp xs  = EvCoercion (mkTcTyConAppCo tc1 (map mkTcCoVarCo xs))
-          xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (mkTcCoVarCo x)) tys1 [0..]
-          xev = XEvTerm xcomp xdecomp
-      in xCtFlavor fl (zipWith mkTcEqPred tys1 tys2) xev (canEqEvVarsCreated d)
-         
+    do { let xcomp xs  = EvCoercion (mkTcTyConAppCo tc1 (map evTermCoercion xs))
+             xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (evTermCoercion x)) tys1 [0..]
+             xev = XEvTerm xcomp xdecomp
+       ; ctevs <- xCtFlavor fl (zipWith mkTcEqPred tys1 tys2) xev
+       ; canEqEvVarsCreated d ctevs }
 
 -- See Note [Equality between type applications]
 --     Note [Care with type applications] in TcUnify
@@ -839,7 +844,7 @@ canEq d fl ty1 ty2    -- e.g.  F a b ~ Maybe c
 
 canEq d fl s1@(ForAllTy {}) s2@(ForAllTy {})
  | tcIsForAllTy s1, tcIsForAllTy s2
- , Wanted loc orig_ev <- fl 
+ , Wanted { ctev_wloc = loc, ctev_evar = orig_ev } <- fl 
  = do { let (tvs1,body1) = tcSplitForAllTys s1
             (tvs2,body2) = tcSplitForAllTys s2
       ; if not (equalLength tvs1 tvs2) then 
@@ -857,12 +862,12 @@ canEq d fl _ _  = canEqFailure d fl
 ------------------------
 -- Type application
 canEqAppTy :: SubGoalDepth 
-           -> CtFlavor 
+           -> CtEvidence 
            -> Type -> Type -> Type -> Type
            -> TcS StopOrContinue
 canEqAppTy d fl s1 t1 s2 t2
   = ASSERT( not (isKind t1) && not (isKind t2) )
-    if isGivenOrSolved fl then 
+    if isGiven fl then 
         do { traceTcS "canEq (app case)" $
                 text "Ommitting decomposition of given equality between: " 
                     <+> ppr (AppTy s1 t1) <+> text "and" <+> ppr (AppTy s2 t2)
@@ -870,14 +875,14 @@ canEqAppTy d fl s1 t1 s2 t2
                    -- because we no longer have 'left' and 'right'
            ; return Stop }
     else 
-      let xevcomp [x,y] = EvCoercion (mkTcAppCo (mkTcCoVarCo x) (mkTcCoVarCo y))
-          xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen
-          xev = XEvTerm { ev_comp = xevcomp
-                        , ev_decomp = error "canEqAppTy: can't happen" }
-      in xCtFlavor fl [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xev $
-         canEqEvVarsCreated d
-
-canEqFailure :: SubGoalDepth -> CtFlavor -> TcS StopOrContinue
+    do { let xevcomp [x,y] = EvCoercion (mkTcAppCo (evTermCoercion x) (evTermCoercion y))
+             xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen
+             xev = XEvTerm { ev_comp = xevcomp
+                           , ev_decomp = error "canEqAppTy: can't happen" }
+       ; ctevs <- xCtFlavor fl [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xev 
+       ; canEqEvVarsCreated d ctevs }
+
+canEqFailure :: SubGoalDepth -> CtEvidence -> TcS StopOrContinue
 canEqFailure d fl = emitFrozenError fl d >> return Stop
 
 ------------------------
@@ -885,12 +890,12 @@ emitKindConstraint :: Ct -> TcS StopOrContinue
 emitKindConstraint ct
   = case ct of 
       CTyEqCan { cc_depth = d
-               , cc_flavor = fl, cc_tyvar = tv
+               , cc_ev = fl, cc_tyvar = tv
                , cc_rhs = ty }
           -> emit_kind_constraint d fl (mkTyVarTy tv) ty
 
       CFunEqCan { cc_depth = d
-                , cc_flavor = fl
+                , cc_ev = fl
                 , cc_fun = fn, cc_tyargs = xis1
                 , cc_rhs = xi2 }
           -> emit_kind_constraint d fl (mkTyConApp fn xis1) xi2
@@ -904,41 +909,43 @@ emitKindConstraint ct
        | otherwise
        = ASSERT( isKind k1 && isKind k2 )
          do { kev <- 
-                 do { mw <- newWantedEvVar (mkEqPred k1 k2) 
+                 do { mw <- newWantedEvVar kind_co_wloc (mkEqPred k1 k2) 
                     ; case mw of
-                         Cached x -> return x
-                         Fresh x  -> addToWork (canEq d (kind_co_fl x) k1 k2) >> return x }
-            ; let xcomp [x] = mkEvKindCast x (mkTcCoVarCo kev)
+                         Cached ev_tm -> return ev_tm
+                         Fresh ctev   -> do { addToWork (canEq d ctev k1 k2) 
+                                            ; return (ctEvTerm ctev) } }
+
+            ; let xcomp [x] = mkEvKindCast x (evTermCoercion kev)
                   xcomp _   = panic "emit_kind_constraint:can't happen"
-                  xdecomp x = [mkEvKindCast x (mkTcCoVarCo kev)]
+                  xdecomp x = [mkEvKindCast x (evTermCoercion kev)]
                   xev = XEvTerm xcomp xdecomp
-              in xCtFlavor_cache False fl [mkTcEqPred ty1 ty2] xev what_next }
+
+            ; ctevs <- xCtFlavor_cache False fl [mkTcEqPred ty1 ty2] xev 
                      -- Important: Do not cache original as Solved since we are supposed to 
                      -- solve /exactly/ the same constraint later! Example:
                      -- (alpha :: kappa0) 
                      -- (T :: *)
                      -- Equality is: (alpha ~ T), so we will emitConstraint (kappa0 ~ *) but
                      -- we don't want to say that (alpha ~ T) is now Solved!
-       where 
-         what_next [new_fl] = continueWith (ct { cc_flavor = new_fl }) 
-         what_next _ = return Stop
 
+            ; case ctevs of
+                []         -> return Stop
+                [new_ctev] -> continueWith (ct { cc_ev = new_ctev }) 
+                _          -> panic "emitKindConstraint" }
+       where
          k1 = typeKind ty1
          k2 = typeKind ty2
          ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2
+
          -- Always create a Wanted kind equality even if 
          -- you are decomposing a given constraint.
          -- NB: DV finds this reasonable for now. Maybe we have to revisit.
-         kind_co_fl x 
-           | isGivenOrSolved fl
-           = let (CtLoc _sk_info src_span err_ctxt) = flav_gloc fl
-                 orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
-                 ctloc = pushErrCtxtSameOrigin ctxt $
-                         CtLoc orig src_span err_ctxt
-             in Wanted ctloc x
-           | otherwise 
-           = Wanted (pushErrCtxtSameOrigin ctxt (flav_wloc fl)) x
-             
+         kind_co_wloc = pushErrCtxtSameOrigin ctxt wanted_loc
+         wanted_loc = case fl of
+                         Wanted  { ctev_wloc = wloc } -> wloc
+                         Derived { ctev_wloc = wloc } -> wloc
+                         Given { ctev_gloc = gloc }   -> setCtLocOrigin gloc orig
+         orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
 \end{code}
 
 Note [Combining insoluble constraints]
@@ -1106,7 +1113,7 @@ classify ty                | Just ty' <- tcView ty
                            = OtherCls ty
 
 -- See note [Canonical ordering for equality constraints].
-reOrient :: CtFlavor -> TypeClassifier -> TypeClassifier -> Bool	
+reOrient :: CtEvidence -> TypeClassifier -> TypeClassifier -> Bool	
 -- (t1 `reOrient` t2) responds True 
 --   iff we should flip to (t2~t1)
 -- We try to say False if possible, to minimise evidence generation
@@ -1143,7 +1150,7 @@ reOrient _fl (FskCls {}) (OtherCls {})   = False
 ------------------
 
 canEqLeaf :: SubGoalDepth -- Depth
-          -> CtFlavor 
+          -> CtEvidence 
           -> Type -> Type 
           -> TcS StopOrContinue
 -- Canonicalizing "leaf" equality constraints which cannot be
@@ -1156,13 +1163,16 @@ canEqLeaf :: SubGoalDepth -- Depth
 canEqLeaf d fl s1 s2 
   | cls1 `re_orient` cls2
   = do { traceTcS "canEqLeaf (reorienting)" $ ppr fl <+> dcolon <+> pprEq s1 s2
-       ; let xcomp [x] = EvCoercion (mkTcSymCo (mkTcCoVarCo x))
+       ; let xcomp [x] = EvCoercion (mkTcSymCo (evTermCoercion x))
              xcomp _ = panic "canEqLeaf: can't happen"
-             xdecomp x = [EvCoercion (mkTcSymCo (mkTcCoVarCo x))]
+             xdecomp x = [EvCoercion (mkTcSymCo (evTermCoercion x))]
              xev = XEvTerm xcomp xdecomp
-             what_next [fl] = canEqLeafOriented d fl s2 s1
-             what_next _ = return Stop
-       ; xCtFlavor fl [mkTcEqPred s2 s1] xev what_next }
+       ; ctevs <- xCtFlavor fl [mkTcEqPred s2 s1] xev 
+       ; case ctevs of
+           []     -> return Stop
+           [ctev] -> canEqLeafOriented d ctev s2 s1
+           _      -> panic "canEqLeaf" }
+
   | otherwise
   = do { traceTcS "canEqLeaf" $ ppr (mkTcEqPred s1 s2)
        ; canEqLeafOriented d fl s1 s2 }
@@ -1172,7 +1182,7 @@ canEqLeaf d fl s1 s2
     cls2 = classify s2
 
 canEqLeafOriented :: SubGoalDepth -- Depth
-                  -> CtFlavor
+                  -> CtEvidence
                   -> TcType -> TcType -> TcS StopOrContinue
 -- By now s1 will either be a variable or a type family application
 canEqLeafOriented d fl s1 s2
@@ -1184,10 +1194,10 @@ canEqLeafOriented d fl s1 s2
           = canEqLeafTyVarLeftRec d fl tv s2
           | otherwise
           = pprPanic "canEqLeafOriented" $
-            text "Non-variable or non-family equality LHS" <+> ppr (ctFlavPred fl)
+            text "Non-variable or non-family equality LHS" <+> ppr (ctEvPred fl)
 
 canEqLeafFunEqLeftRec :: SubGoalDepth
-                      -> CtFlavor
+                      -> CtEvidence
                       -> (TyCon,[TcType]) -> TcType -> TcS StopOrContinue
 canEqLeafFunEqLeftRec d fl (fn,tys1) ty2  -- fl :: F tys1 ~ ty2
   = do { traceTcS "canEqLeafFunEqLeftRec" $ pprEq (mkTyConApp fn tys1) ty2
@@ -1210,7 +1220,7 @@ canEqLeafFunEqLeftRec d fl (fn,tys1) ty2  -- fl :: F tys1 ~ ty2
 
 
 canEqLeafFunEqLeft :: SubGoalDepth -- Depth
-                   -> CtFlavor
+                   -> CtEvidence
                    -> (TyCon,[Xi])
                    -> TcType -> TcS StopOrContinue
 -- Precondition: No more flattening is needed for the LHS
@@ -1232,12 +1242,12 @@ canEqLeafFunEqLeft d fl (fn,xis1) s2
       ; case mb of
           Nothing -> return Stop
           Just new_fl -> continueWith $ 
-                         CFunEqCan { cc_flavor = new_fl, cc_depth = d
+                         CFunEqCan { cc_ev = new_fl, cc_depth = d
                                    , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } }   
 
 
 canEqLeafTyVarLeftRec :: SubGoalDepth
-                      -> CtFlavor
+                      -> CtEvidence
                       -> TcTyVar -> TcType -> TcS StopOrContinue
 canEqLeafTyVarLeftRec d fl tv s2              -- fl :: tv ~ s2
   = do {  traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2
@@ -1262,7 +1272,7 @@ canEqLeafTyVarLeftRec d fl tv s2              -- fl :: tv ~ s2
                Nothing  -> canEq d new_fl xi1 s2 }
     
 canEqLeafTyVarLeft :: SubGoalDepth -- Depth
-                   -> CtFlavor 
+                   -> CtEvidence 
                    -> TcTyVar -> TcType -> TcS StopOrContinue
 -- Precondition LHS is fully rewritten from inerts (but not RHS)
 canEqLeafTyVarLeft d fl tv s2       -- eqv : tv ~ s2
@@ -1276,7 +1286,7 @@ canEqLeafTyVarLeft d fl tv s2       -- eqv : tv ~ s2
 
        -- Reflexivity exposed through flattening        
        ; if tv_ty `eqType` xi2 then
-           when (isWanted fl) (setEvBind (flav_evar fl) (EvCoercion co2)) >> 
+           when (isWanted fl) (setEvBind (ctev_evar fl) (EvCoercion co2)) >> 
            return Stop
          else do
        -- Not reflexivity but maybe an occurs error
@@ -1291,7 +1301,7 @@ canEqLeafTyVarLeft d fl tv s2       -- eqv : tv ~ s2
        ; case mb of
            Just new_fl -> if not_occ_err then 
                             continueWith $
-                            CTyEqCan { cc_flavor = new_fl, cc_depth = d
+                            CTyEqCan { cc_ev = new_fl, cc_depth = d
                                      , cc_tyvar  = tv, cc_rhs    = xi2' }
                           else
                             canEqFailure d new_fl
@@ -1307,7 +1317,7 @@ canEqLeafTyVarLeft d fl tv s2       -- eqv : tv ~ s2
 -- variable, then the same type is returned.
 --
 -- Precondition: the two types are not equal (looking though synonyms)
-canOccursCheck :: CtFlavor -> TcTyVar -> Xi -> TcS (Maybe Xi)
+canOccursCheck :: CtEvidence -> TcTyVar -> Xi -> TcS (Maybe Xi)
 canOccursCheck _gw tv xi = return (expandAway tv xi)
 \end{code}
 
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 63a5beeb24..483de071d4 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -10,8 +10,6 @@
 module TcErrors( 
        reportUnsolved, ErrEnv,
        warnDefaulting,
-       unifyCtxt,
-       misMatchMsg,
 
        flattenForAllErrorTcS,
        solverDepthErrorTcS
@@ -160,17 +158,15 @@ reportTidyWanteds ctxt insols flats implics
 deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) 
                -> Ct -> TcM ()
 deferToRuntime ev_binds_var ctxt mk_err_msg ct 
-  | fl <- cc_flavor ct
-  , Wanted loc _ <- fl
+  | Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
   = do { err <- setCtLoc loc $
                 mk_err_msg ctxt ct
-       ; let ev_id   = ctId ct -- Prec satisfied: Wanted
-             err_msg = pprLocErrMsg err
+       ; let err_msg = pprLocErrMsg err
              err_fs  = mkFastString $ showSDoc $ 
                        err_msg $$ text "(deferred type error)"
 
          -- Create the binding
-       ; addTcEvBind ev_binds_var ev_id (EvDelayedError (idType ev_id) err_fs)
+       ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs)
 
          -- And emit a warning
        ; reportWarning (makeIntoWarning err) }
@@ -233,7 +229,7 @@ type Reporter = [Ct] -> TcM ()
 
 mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM ()
 -- Reports errors one at a time
-mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_flavor ct) $
+mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_ev ct) $
                                               mk_err ct; 
                                      ; reportError err })
 
@@ -318,15 +314,15 @@ groupErrs mk_err (ct1 : rest)
         ; reportError err
         ; groupErrs mk_err others }
   where
-   flavor            = cc_flavor ct1
+   flavor            = cc_ev ct1
    cts               = ct1 : friends
    (friends, others) = partition is_friend rest
-   is_friend friend  = cc_flavor friend `same_group` flavor
+   is_friend friend  = cc_ev friend `same_group` flavor
 
-   same_group :: CtFlavor -> CtFlavor -> Bool
-   same_group (Given l1 _) (Given l2 _) = same_loc l1 l2
-   same_group (Derived l1 _) (Derived l2 _) = same_loc l1 l2
-   same_group (Wanted l1 _)  (Wanted l2 _)  = same_loc l1 l2
+   same_group :: CtEvidence -> CtEvidence -> Bool
+   same_group (Given   {ctev_gloc = l1}) (Given   {ctev_gloc = l2}) = same_loc l1 l2
+   same_group (Wanted  {ctev_wloc = l1}) (Wanted  {ctev_wloc = l2}) = same_loc l1 l2
+   same_group (Derived {ctev_wloc = l1}) (Derived {ctev_wloc = l2}) = same_loc l1 l2
    same_group _ _ = False
 
    same_loc :: CtLoc o -> CtLoc o -> Bool
@@ -427,7 +423,7 @@ mkEqErr _ [] = panic "mkEqErr"
 mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
 -- Wanted constraints only!
 mkEqErr1 ctxt ct
-  = if isGivenOrSolved flav then 
+  = if isGiven flav then 
       let ctx2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg flav }
       in mkEqErr_help ctx2 ct False ty1 ty2
     else
@@ -436,10 +432,11 @@ mkEqErr1 ctxt ct
          ; mk_err ctxt1 orig' }
   where
 
-    flav = cc_flavor ct
+    flav = cc_ev ct
 
-    inaccessible_msg (Given loc _) = hang (ptext (sLit "Inaccessible code in"))
-                                        2 (ppr (ctLocOrigin loc))
+    inaccessible_msg (Given { ctev_gloc = loc }) 
+       = hang (ptext (sLit "Inaccessible code in"))
+            2 (ppr (ctLocOrigin loc))
     -- If a Solved then we should not report inaccessible code
     inaccessible_msg _ = empty
 
@@ -573,7 +570,7 @@ misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc
 misMatchOrCND ctxt ct oriented ty1 ty2
   | null givens || 
     (isRigid ty1 && isRigid ty2) || 
-    isGivenOrSolved (cc_flavor ct)
+    isGiven (cc_ev ct)
        -- If the equality is unconditionally insoluble
        -- or there is no context, don't report the context
   = misMatchMsg oriented ty1 ty2
@@ -641,12 +638,6 @@ kindErrorMsg ty1 ty2
     k2 = typeKind ty2
 
 --------------------
-unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
-unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
-  = do  { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty
-        ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty
-        ; return (env2, mkExpectedActualMsg exp_ty' act_ty') }
-
 misMatchMsg :: Bool -> TcType -> TcType -> SDoc	   -- Types are already tidy
 -- If oriented then ty1 is expected, ty2 is actual
 misMatchMsg oriented ty1 ty2 
@@ -1074,7 +1065,7 @@ solverDepthErrorTcS depth stack
   | null stack	    -- Shouldn't happen unless you say -fcontext-stack=0
   = failWith msg
   | otherwise
-  = setCtFlavorLoc (cc_flavor top_item) $
+  = setCtFlavorLoc (cc_ev top_item) $
     do { zstack <- mapM zonkCt stack
        ; env0 <- tcInitTidyEnv
        ; let zstack_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet zstack
@@ -1087,7 +1078,7 @@ solverDepthErrorTcS depth stack
                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 
 {- DV: Changing this because Derived's no longer have ids ... Kind of a corner case ...
-  = setCtFlavorLoc (cc_flavor top_item) $
+  = setCtFlavorLoc (cc_ev top_item) $
     do { ev_vars <- mapM (zonkEvVar . cc_id) stack
        ; env0 <- tcInitTidyEnv
        ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars)
@@ -1100,7 +1091,7 @@ solverDepthErrorTcS depth stack
 -}
 
 
-flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a
+flattenForAllErrorTcS :: CtEvidence -> TcType -> TcM a
 flattenForAllErrorTcS fl ty
   = setCtFlavorLoc fl $ 
     do { env0 <- tcInitTidyEnv
@@ -1117,11 +1108,10 @@ flattenForAllErrorTcS fl ty
 %************************************************************************
 
 \begin{code}
-setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted  loc _) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
-setCtFlavorLoc (Given loc _)   thing = setCtLoc loc thing
-setCtFlavorLoc (Solved loc _)  thing = setCtLoc loc thing
+setCtFlavorLoc :: CtEvidence -> TcM a -> TcM a
+setCtFlavorLoc (Wanted  { ctev_wloc = loc }) thing = setCtLoc loc thing
+setCtFlavorLoc (Derived { ctev_wloc = loc }) thing = setCtLoc loc thing
+setCtFlavorLoc (Given   { ctev_gloc = loc }) thing = setCtLoc loc thing
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index 8ec0a5766b..82298a470b 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -17,7 +17,7 @@ module TcEvidence (
   EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, 
 
   EvTerm(..), mkEvCast, evVarsOfTerm, mkEvKindCast,
-  EvLit(..),
+  EvLit(..), evTermCoercion,
 
   -- TcCoercion
   TcCoercion(..), 
@@ -36,7 +36,7 @@ import Var
 import PprCore ()   -- Instance OutputableBndr TyVar
 import TypeRep  -- Knows type representation
 import TcType
-import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe )
+import Type( tyConAppArgN, getEqPredTys_maybe, tyConAppTyCon_maybe, getEqPredTys )
 import TysPrim( funTyCon )
 import TyCon
 import PrelNames
@@ -102,6 +102,7 @@ data TcCoercion
   | TcSymCo TcCoercion
   | TcTransCo TcCoercion TcCoercion
   | TcNthCo Int TcCoercion
+  | TcCastCo TcCoercion TcCoercion     -- co1 |> co2
   | TcLetCo TcEvBinds TcCoercion
   deriving (Data.Data, Data.Typeable)
 
@@ -199,6 +200,8 @@ tcCoercionKind co = go co
   where 
     go (TcRefl ty)            = Pair ty ty
     go (TcLetCo _ co)         = go co
+    go (TcCastCo _ co)        = case getEqPredTys (pSnd (go co)) of
+                                   (ty1,ty2) -> Pair ty1 ty2
     go (TcTyConAppCo tc cos)  = mkTyConApp tc <$> (sequenceA $ map go cos)
     go (TcAppCo co1 co2)      = mkAppTy <$> go co1 <*> go co2
     go (TcForAllCo tv co)     = mkForAllTy tv <$> go co
@@ -206,8 +209,8 @@ tcCoercionKind co = go co
     go (TcCoVarCo cv)         = eqVarKind cv
     go (TcAxiomInstCo ax tys) = Pair (substTyWith (co_ax_tvs ax) tys (co_ax_lhs ax)) 
                                      (substTyWith (co_ax_tvs ax) tys (co_ax_rhs ax))
-    go (TcSymCo co)           = swap $ go co
-    go (TcTransCo co1 co2)    = Pair (pFst $ go co1) (pSnd $ go co2)
+    go (TcSymCo co)           = swap (go co)
+    go (TcTransCo co1 co2)    = Pair (pFst (go co1)) (pSnd (go co2))
     go (TcNthCo d co)         = tyConAppArgN d <$> go co
 
     -- c.f. Coercion.coercionKind
@@ -219,7 +222,7 @@ eqVarKind cv
  | Just (tc, [_kind,ty1,ty2]) <- tcSplitTyConApp_maybe (varType cv)
  = ASSERT (tc `hasKey` eqTyConKey)
    Pair ty1 ty2
- | otherwise = panic "eqVarKind, non coercion variable"
+ | otherwise = pprPanic "eqVarKind, non coercion variable" (ppr cv <+> dcolon <+> ppr (varType cv))
 
 coVarsOfTcCo :: TcCoercion -> VarSet
 -- Only works on *zonked* coercions, because of TcLetCo
@@ -229,6 +232,7 @@ coVarsOfTcCo tc_co
     go (TcRefl _)                = emptyVarSet
     go (TcTyConAppCo _ cos)      = foldr (unionVarSet . go) emptyVarSet cos
     go (TcAppCo co1 co2)         = go co1 `unionVarSet` go co2
+    go (TcCastCo co1 co2)        = go co1 `unionVarSet` go co2
     go (TcForAllCo _ co)         = go co
     go (TcInstCo co _)           = go co
     go (TcCoVarCo v)             = unitVarSet v
@@ -263,7 +267,7 @@ liftTcCoSubstWith tvs cos ty
                              Nothing -> mkTcReflCo ty
     go (AppTy t1 t2)     = mkTcAppCo (go t1) (go t2)
     go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys)
-    go ty@(LitTy {})     = mkTcReflCo ty

+    go ty@(LitTy {})     = mkTcReflCo ty
     go (ForAllTy tv ty)  = mkTcForAllCo tv (go ty)
     go (FunTy t1 t2)     = mkTcFunCo (go t1) (go t2)
 \end{code}
@@ -289,6 +293,8 @@ ppr_co p (TcLetCo bs co)         = maybeParen p TopPrec $
                                    sep [ptext (sLit "let") <+> braces (ppr bs), ppr co]
 ppr_co p (TcAppCo co1 co2)       = maybeParen p TyConPrec $
                                    pprTcCo co1 <+> ppr_co TyConPrec co2
+ppr_co p (TcCastCo co1 co2)      = maybeParen p FunPrec $
+                                   ppr_co FunPrec co1 <+> ptext (sLit "|>") <+> ppr_co FunPrec co2
 ppr_co p co@(TcForAllCo {})      = ppr_forall_co p co
 ppr_co p (TcInstCo co ty)        = maybeParen p TyConPrec $
                                    pprParendTcCo co <> ptext (sLit "@") <> pprType ty
@@ -454,24 +460,24 @@ data EvTerm
 
   | EvCoercion TcCoercion        -- (Boxed) coercion bindings
 
-  | EvCast EvVar TcCoercion      -- d |> co
+  | EvCast EvTerm TcCoercion     -- d |> co
 
   | EvDFunApp DFunId             -- Dictionary instance application
-       [Type] [EvVar]
+       [Type] [EvTerm]
 
-  | EvTupleSel EvId  Int         -- n'th component of the tuple
+  | EvTupleSel EvTerm  Int       -- n'th component of the tuple, 0-indexed
 
-  | EvTupleMk [EvId]             -- tuple built from this stuff
+  | EvTupleMk [EvTerm]           -- tuple built from this stuff
 
   | EvDelayedError Type FastString  -- Used with Opt_DeferTypeErrors
                                -- See Note [Deferring coercion errors to runtime]
                                -- in TcSimplify
 
-  | EvSuperClass DictId Int      -- n'th superclass. Used for both equalities and
+  | EvSuperClass EvTerm Int      -- n'th superclass. Used for both equalities and
                                  -- dictionaries, even though the former have no
                                  -- selector Id.  We count up from _0_
 
-  | EvKindCast EvVar TcCoercion  -- See Note [EvKindCast]
+  | EvKindCast EvTerm TcCoercion  -- See Note [EvKindCast]
 
   | EvLit EvLit                  -- Dictionary for class "SingI" for type lits.
                                  -- Note [EvLit]
@@ -555,14 +561,14 @@ and another to make it into "SingI" evidence.
 
 
 \begin{code}
-mkEvCast :: EvVar -> TcCoercion -> EvTerm
+mkEvCast :: EvTerm -> TcCoercion -> EvTerm
 mkEvCast ev lco
-  | isTcReflCo lco = EvId ev
+  | isTcReflCo lco = ev
   | otherwise      = EvCast ev lco
 
-mkEvKindCast :: EvVar -> TcCoercion -> EvTerm
+mkEvKindCast :: EvTerm -> TcCoercion -> EvTerm
 mkEvKindCast ev lco
-  | isTcReflCo lco = EvId ev
+  | isTcReflCo lco = ev
   | otherwise      = EvKindCast ev lco
 
 emptyTcEvBinds :: TcEvBinds
@@ -573,17 +579,27 @@ isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b
 isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
 
 
-evVarsOfTerm :: EvTerm -> [EvVar]
-evVarsOfTerm (EvId v) = [v]
-evVarsOfTerm (EvCoercion co)      = varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvDFunApp _ _ evs)  = evs
-evVarsOfTerm (EvTupleSel v _)     = [v]
-evVarsOfTerm (EvSuperClass v _)   = [v]
-evVarsOfTerm (EvCast v co)        = v : varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvTupleMk evs)      = evs
-evVarsOfTerm (EvDelayedError _ _) = []
-evVarsOfTerm (EvKindCast v co)   = v : varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvLit _)            = []
+evTermCoercion :: EvTerm -> TcCoercion
+-- Applied only to EvTerms of type (s~t)
+evTermCoercion (EvId v)        = mkTcCoVarCo v
+evTermCoercion (EvCoercion co) = co
+evTermCoercion (EvCast tm co)  = TcCastCo (evTermCoercion tm) co
+evTermCoercion tm = pprPanic "evTermCoercion" (ppr tm)
+
+evVarsOfTerm :: EvTerm -> VarSet
+evVarsOfTerm (EvId v)             = unitVarSet v
+evVarsOfTerm (EvCoercion co)      = coVarsOfTcCo co
+evVarsOfTerm (EvDFunApp _ _ evs)  = evVarsOfTerms evs
+evVarsOfTerm (EvTupleSel v _)     = evVarsOfTerm v
+evVarsOfTerm (EvSuperClass v _)   = evVarsOfTerm v
+evVarsOfTerm (EvCast tm co)       = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo co
+evVarsOfTerm (EvTupleMk evs)      = evVarsOfTerms evs
+evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
+evVarsOfTerm (EvKindCast v co)    = coVarsOfTcCo co `unionVarSet` evVarsOfTerm v
+evVarsOfTerm (EvLit _)            = emptyVarSet
+
+evVarsOfTerms :: [EvTerm] -> VarSet
+evVarsOfTerms = foldr (unionVarSet . evVarsOfTerm) emptyVarSet 
 \end{code}
 
 
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 34632a5a77..e6586d8ff5 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -203,12 +203,14 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
 \begin{code}
 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _))
+tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh l@(CLabel _))
   = ASSERT( null arg_tys )
-    do { checkCg checkCOrAsmOrLlvmOrInterp
-       ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
-       ; return idecl }      -- NB check res_ty not sig_ty!
-                             --    In case sig_ty is (forall a. ForeignPtr a)
+    do checkCg checkCOrAsmOrLlvmOrInterp
+       -- NB check res_ty not sig_ty!
+       --    In case sig_ty is (forall a. ForeignPtr a)
+       check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
+       cconv' <- checkCConv cconv
+       return (CImport cconv' safety mh l)
 
 tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do
         -- Foreign wrapper (former f.e.d.)
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index a4af0ce7f3..9104016938 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -770,19 +770,18 @@ zonkStmts env (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env) s
 			  ; return (env2, s' : ss') }
 
 zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id)
-zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op)
-  = mappM zonk_branch stmts_w_bndrs	`thenM` \ new_stmts_w_bndrs ->
-    let 
-	new_binders = concat (map snd new_stmts_w_bndrs)
-	env1 = extendIdZonkEnv env new_binders
-    in
-    zonkExpr env1 mzip_op   `thenM` \ new_mzip ->
-    zonkExpr env1 bind_op   `thenM` \ new_bind ->
-    zonkExpr env1 return_op `thenM` \ new_return ->
-    return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return)
+zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op)
+  = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs
+       ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
+	     env1 = extendIdZonkEnv env new_binders
+       ; new_mzip <- zonkExpr env1 mzip_op
+       ; new_bind <- zonkExpr env1 bind_op
+       ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) }
   where
-    zonk_branch (stmts, bndrs) = zonkStmts env stmts	`thenM` \ (env1, new_stmts) ->
-				 returnM (new_stmts, zonkIdOccs env1 bndrs)
+    zonk_branch (ParStmtBlock stmts bndrs return_op) 
+       = do { (env1, new_stmts) <- zonkStmts env stmts
+            ; new_return <- zonkExpr env1 return_op
+	    ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) }
 
 zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
                       , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
@@ -1096,21 +1095,24 @@ zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v )
                                     return (EvId (zonkIdOcc env v))
 zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcLCoToLCo env co
                                        ; return (EvCoercion co') }
-zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
-                                    do { co' <- zonkTcLCoToLCo env co
-                                       ; return (mkEvCast (zonkIdOcc env v) co') }
-
-zonkEvTerm env (EvKindCast v co) = ASSERT( isId v) 
-                                    do { co' <- zonkTcLCoToLCo env co
-                                       ; return (mkEvKindCast (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 (EvCast tm co)     = do { tm' <- zonkEvTerm env tm
+                                       ; co' <- zonkTcLCoToLCo env co
+                                       ; return (mkEvCast tm' co') }
+
+zonkEvTerm env (EvKindCast v co)  = do { v'  <- zonkEvTerm env v
+                                       ; co' <- zonkTcLCoToLCo env co
+                                       ; return (mkEvKindCast v' co') }
+
+zonkEvTerm env (EvTupleSel tm n)  = do { tm' <- zonkEvTerm env tm
+                                       ; return (EvTupleSel tm' n) }
+zonkEvTerm env (EvTupleMk tms)    = do { tms' <- mapM (zonkEvTerm env) tms
+                                       ; return (EvTupleMk tms') }
 zonkEvTerm _   (EvLit l)          = return (EvLit l)
-zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
+zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
+                                       ; return (EvSuperClass d' n) }
 zonkEvTerm env (EvDFunApp df tys tms)
   = do { tys' <- zonkTcTypeToTypes env tys
-       ; let tms' = map (zonkEvVarOcc env) tms
+       ; tms' <- mapM (zonkEvTerm env) tms
        ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
 zonkEvTerm env (EvDelayedError ty msg)
   = do { ty' <- zonkTcTypeToType env ty
@@ -1345,6 +1347,8 @@ zonkTcLCoToLCo env co
     go (TcAxiomInstCo ax tys) = do { tys' <- zonkTcTypeToTypes env tys; return (TcAxiomInstCo ax tys') }
     go (TcAppCo co1 co2)      = do { co1' <- go co1; co2' <- go co2
                                    ; return (mkTcAppCo co1' co2') }
+    go (TcCastCo co1 co2)     = do { co1' <- go co1; co2' <- go co2
+                                   ; return (TcCastCo co1' co2') }
     go (TcSymCo co)           = do { co' <- go co; return (mkTcSymCo co')  }
     go (TcNthCo n co)         = do { co' <- go co; return (mkTcNthCo n co')  }
     go (TcTransCo co1 co2)    = do { co1' <- go co1; co2' <- go co2
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 776689084f..bc217bb041 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -840,7 +840,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
              mk_sc_ev_term sc
                | null inst_tv_tys
                , null dfun_ev_vars = EvId sc
-               | otherwise         = EvDFunApp sc inst_tv_tys dfun_ev_vars
+               | otherwise         = EvDFunApp sc inst_tv_tys (map EvId dfun_ev_vars)
 
              inst_tv_tys    = mkTyVarTys inst_tyvars
              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
@@ -1141,7 +1141,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
            ; self_dict <- newDict clas inst_tys
            ; let self_ev_bind = EvBind self_dict
-                                (EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars)
+                                (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
 
            ; (meth_id, local_meth_sig) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
                                                    inst_tys sel_id
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index c62c778736..44d6a8d01f 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -31,7 +31,6 @@ import TyCon
 import Name
 import IParam
 
-import TysWiredIn ( eqTyCon )
 import FunDeps
 
 import TcEvidence
@@ -46,7 +45,6 @@ import Maybes( orElse )
 import Bag
 
 import Control.Monad ( foldM )
-import TrieMap
 
 import VarEnv
 import qualified Data.Traversable as Traversable
@@ -106,8 +104,11 @@ solveInteractGiven :: GivenLoc -> [EvVar] -> TcS (Bag Implication)
 -- if this can happen in practice though.
 solveInteractGiven gloc evs
   = solveInteractCts (map mk_noncan evs)
-  where mk_noncan ev = CNonCanonical { cc_flavor = Given gloc ev
-                                     , cc_depth = 0 }
+  where 
+    mk_noncan ev = CNonCanonical { cc_ev = Given { ctev_gloc = gloc 
+                                                 , ctev_evtm = EvId ev
+                                                 , ctev_pred = evVarPred ev }
+                                 , cc_depth = 0 }
 
 -- The main solver loop implements Note [Basic Simplifier Plan]
 ---------------------------------------------------------------
@@ -229,13 +230,13 @@ thePipeline = [ ("lookup-in-inerts",        lookupInInertsStage)
 --------------------------------------------------------------------
 lookupInInertsStage :: SimplifierStage
 lookupInInertsStage ct
-  | isWantedCt ct
+  | Wanted { ctev_evar = ev_id, ctev_pred = pred } <- cc_ev ct
   = do { is <- getTcSInerts
-       ; case lookupInInerts is (ctPred ct) of
-           Just ct_cached 
-             |  not (isDerivedCt ct)
-             -> setEvBind (ctId ct) (EvId (ctId ct_cached)) >> 
-                return Stop
+       ; case lookupInInerts is pred of
+           Just ctev
+             |  not (isDerived ctev)
+             -> do { setEvBind ev_id (ctEvTerm ctev)
+                   ; return Stop }
            _ -> continueWith ct }
   | otherwise -- I could do something like that for givens 
               -- as well I suppose but it is not a big deal
@@ -246,7 +247,6 @@ lookupInInertsStage ct
 ----------------------------------------------------------
 canonicalizationStage :: SimplifierStage
 canonicalizationStage = TcCanonical.canonicalize 
-
 \end{code}
 
 *********************************************************************************
@@ -321,7 +321,7 @@ kickOutRewritableInerts ct
 
        ; new_ieqs <- {-# SCC "rewriteInertEqsFromInertEq" #-}
                      rewriteInertEqsFromInertEq (cc_tyvar ct,
-                                                 ct_coercion,cc_flavor ct) ieqs
+                                                 ct_coercion,cc_ev ct) ieqs
        ; let upd_eqs is = is { inert_cans = new_ics }
                         where ics     = inert_cans is
                               new_ics = ics { inert_eqs = new_ieqs }
@@ -336,7 +336,7 @@ kickOutRewritableInerts ct
        ; traceTcS "Kick out" (ppr ct $$ ppr wl)
        ; updWorkListTcS (unionWorkList wl) }
 
-rewriteInertEqsFromInertEq :: (TcTyVar, TcCoercion, CtFlavor) -- A new substitution
+rewriteInertEqsFromInertEq :: (TcTyVar, TcCoercion, CtEvidence) -- A new substitution
                            -> TyVarEnv Ct                     -- All the inert equalities
                            -> TcS (TyVarEnv Ct)               -- The new inert equalities
 rewriteInertEqsFromInertEq (subst_tv, _subst_co, subst_fl) ieqs
@@ -366,7 +366,7 @@ rewriteInertEqsFromInertEq (subst_tv, _subst_co, subst_fl) ieqs
          | otherwise -- Just keep it there
          = return (Just ct)
          where 
-           fl  = cc_flavor ct
+           fl  = cc_ev ct
 
 kick_out_rewritable :: Ct 
                     -> InertSet 
@@ -401,7 +401,7 @@ kick_out_rewritable ct is@(IS { inert_cans =
                 -- inert_solved, inert_flat_cache and inert_solved_funeqs
                 -- optimistically. But when we lookup we have to take the 
                 -- subsitution into account
-    fl = cc_flavor ct
+    fl = cc_ev ct
     tv = cc_tyvar ct
                                
     (ips_out,   ips_in)     = partitionCCanMap rewritable ipmap
@@ -412,7 +412,7 @@ kick_out_rewritable ct is@(IS { inert_cans =
     (irs_out,   irs_in)   = partitionBag rewritable irreds
     (fro_out,   fro_in)   = partitionBag rewritable frozen
 
-    rewritable ct = (fl `canRewrite` cc_flavor ct)  &&
+    rewritable ct = (fl `canRewrite` cc_ev ct)  &&
                     (tv `elemVarSet` tyVarsOfCt ct) 
                     -- NB: tyVarsOfCt will return the type 
                     --     variables /and the kind variables/ that are 
@@ -461,9 +461,9 @@ data SPSolveResult = SPCantSolve
 -- touchable unification variable.
 --     	    See Note [Touchables and givens] 
 trySpontaneousSolve :: WorkItem -> TcS SPSolveResult
-trySpontaneousSolve workItem@(CTyEqCan { cc_flavor = gw
+trySpontaneousSolve workItem@(CTyEqCan { cc_ev = gw
                                        , cc_tyvar = tv1, cc_rhs = xi, cc_depth = d })
-  | isGivenOrSolved gw
+  | isGiven gw
   = return SPCantSolve
   | Just tv2 <- tcGetTyVar_maybe xi
   = do { tch1 <- isTouchableMetaTyVar tv1
@@ -488,7 +488,7 @@ trySpontaneousSolve _ = return SPCantSolve
 
 ----------------
 trySpontaneousEqOneWay :: SubGoalDepth 
-                       -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult
+                       -> CtEvidence -> TcTyVar -> Xi -> TcS SPSolveResult
 -- tv is a MetaTyVar, not untouchable
 trySpontaneousEqOneWay d gw tv xi
   | not (isSigTyVar tv) || isTyVarTy xi
@@ -498,7 +498,7 @@ trySpontaneousEqOneWay d gw tv xi
 
 ----------------
 trySpontaneousEqTwoWay :: SubGoalDepth 
-                       -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult
+                       -> CtEvidence -> TcTyVar -> TcTyVar -> TcS SPSolveResult
 -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here
 
 trySpontaneousEqTwoWay d gw tv1 tv2
@@ -585,10 +585,10 @@ unification variables as RHS of type family equations: F xis ~ alpha.
 ----------------
 
 solveWithIdentity :: SubGoalDepth 
-                  -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult
+                  -> CtEvidence -> 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
+-- Precondition: CtEvidence is Wanted or Derived
 -- See [New Wanted Superclass Work] to see why solveWithIdentity 
 --     must work for Derived as well as Wanted
 -- Returns: workItem where 
@@ -607,17 +607,18 @@ solveWithIdentity d wd tv xi
                -- cf TcUnify.uUnboundKVar
 
        ; setWantedTyBind tv xi'
-       ; let refl_xi = mkTcReflCo xi'
+       ; let refl_evtm = EvCoercion (mkTcReflCo xi')
+             refl_pred = mkTcEqPred tv_ty xi'
 
        ; when (isWanted wd) $ 
-              setEvBind (flav_evar wd) (EvCoercion refl_xi)
+              setEvBind (ctev_evar wd) refl_evtm
 
-       ; ev_given <- newGivenEvVar (mkTcEqPred tv_ty xi') 
-                                   (EvCoercion refl_xi) >>= (return . mn_thing)
-       ; let given_fl = Given (mkGivenLoc (flav_wloc wd) UnkSkol) ev_given
+       ; let given_fl = Given { ctev_gloc = mkGivenLoc (ctev_wloc wd) UnkSkol
+                              , ctev_pred = refl_pred
+                              , ctev_evtm = refl_evtm }
              
        ; return $ 
-         SPSolved (CTyEqCan { cc_flavor = given_fl
+         SPSolved (CTyEqCan { cc_ev = given_fl
                             , cc_tyvar  = tv, cc_rhs = xi', cc_depth = d }) }
 \end{code}
 
@@ -654,7 +655,7 @@ or, equivalently,
    then there is no reaction
 
 \begin{code}
--- Interaction result of  WorkItem <~> AtomicInert
+-- Interaction result of  WorkItem <~> Ct
 
 data InteractResult 
     = IRWorkItemConsumed { ir_fire :: String } 
@@ -715,8 +716,8 @@ interactWithInertsStage wi
 doInteractWithInert :: Ct -> Ct -> TcS InteractResult
 -- Identical class constraints.
 doInteractWithInert
-  inertItem@(CDictCan { cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) 
-   workItem@(CDictCan { cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 })
+  inertItem@(CDictCan { cc_ev = fl1, cc_class = cls1, cc_tyargs = tys1 }) 
+   workItem@(CDictCan { cc_ev = fl2, cc_class = cls2, cc_tyargs = tys2 })
 
   | cls1 == cls2  
   = do { let pty1 = mkClassPred cls1 tys1
@@ -728,13 +729,13 @@ doInteractWithInert
                                               , text "workItem  = " <+> ppr workItem ])
 
        ; any_fundeps 
-           <- if isGivenOrSolved fl1 && isGivenOrSolved fl2 then return Nothing
+           <- if isGiven fl1 && isGiven fl2 then return Nothing
               -- NB: We don't create fds for given (and even solved), have not seen a useful
               -- situation for these and even if we did we'd have to be very careful to only
               -- create Derived's and not Wanteds. 
 
               else do { let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc
-                      ; wloc  <- get_workitem_wloc fl2 
+                            wloc    = getWantedLoc fl2 
                       ; rewriteWithFunDeps fd_eqns tys2 wloc }
                       -- See Note [Efficient Orientation], [When improvement happens]
 
@@ -745,23 +746,18 @@ doInteractWithInert
                | otherwise         -> irKeepGoing "NOP"
 
            -- Actual Functional Dependencies
-           Just (_rewritten_tys2,_cos2,fd_work)
+           Just (_rewritten_tys2, 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 { emitFDWorkAsDerived fd_work (cc_depth workItem)
                      ; irKeepGoing "Cls/Cls (new fundeps)" } -- Just keep going without droping the inert 
        }
-  where get_workitem_wloc (Wanted wl _)  = return wl 
-        get_workitem_wloc (Derived wl _) = return wl
-        get_workitem_wloc _ = pprPanic "Unexpected given workitem!" $
-                              vcat [ text "Work item =" <+> ppr workItem
-                                   , text "Inert item=" <+> ppr inertItem]
-
+ 
 -- 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)
-doInteractWithInert (CIrredEvCan { cc_flavor = ifl, cc_ty = ty1 })
+doInteractWithInert (CIrredEvCan { cc_ev = ifl, cc_ty = ty1 })
            workItem@(CIrredEvCan { cc_ty = ty2 })
   | ty1 `eqType` ty2
   = solveOneFromTheOther "Irred/Irred" ifl workItem
@@ -771,9 +767,9 @@ doInteractWithInert (CIrredEvCan { cc_flavor = ifl, cc_ty = ty1 })
 -- that equates the type (this is "improvement").  
 -- However, we don't actually need the coercion evidence,
 -- so we just generate a fresh coercion variable that isn't used anywhere.
-doInteractWithInert (CIPCan { cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) 
-           workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
-  | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl
+doInteractWithInert (CIPCan { cc_ev = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) 
+           workItem@(CIPCan { cc_ev = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
+  | nm1 == nm2 && isGiven wfl && isGiven ifl
   = 	-- See Note [Overriding implicit parameters]
         -- Dump the inert item, override totally with the new one
 	-- Do not require type equality
@@ -786,44 +782,43 @@ doInteractWithInert (CIPCan { cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 })
 
   | nm1 == nm2
   =  	-- See Note [When improvement happens]
-    do { mb_eqv <- newWantedEvVar (mkEqPred ty2 ty1)
+    do { mb_eqv <- newWantedEvVar new_wloc (mkEqPred ty2 ty1)
          -- co :: ty2 ~ ty1, see Note [Efficient orientation]
        ; cv <- case mb_eqv of
                  Fresh eqv  -> 
                    do { updWorkListTcS $ extendWorkListEq $ 
-                        CNonCanonical { cc_flavor = Wanted new_wloc eqv
+                        CNonCanonical { cc_ev = eqv
                                       , cc_depth = cc_depth workItem }
-                      ; return eqv }
+                      ; return (ctEvTerm eqv) }
                  Cached eqv -> return eqv
        ; case wfl of
-            Wanted  {} ->
-              let ip_co = mkTcTyConAppCo (ipTyCon nm1) [mkTcCoVarCo cv]
-              in do { setEvBind (ctId workItem) $
-                      mkEvCast (flav_evar ifl) (mkTcSymCo ip_co)
+            Wanted { ctev_evar = ev_id } ->
+              let ip_co = mkTcTyConAppCo (ipTyCon nm1) [evTermCoercion cv]
+              in do { setEvBind ev_id $
+                      mkEvCast (ctEvTerm ifl) (mkTcSymCo ip_co)
                     ; irWorkItemConsumed "IP/IP (solved by rewriting)" }
             _ -> pprPanic "Unexpected IP constraint" (ppr workItem) }
-  where new_wloc
-          | Wanted wl _  <- wfl = wl
-          | Derived wl _ <- wfl = wl
-          | Wanted wl _  <- ifl = wl
-          | Derived wl _ <- ifl = wl
-          | otherwise = panic "Solve IP: no WantedLoc!"
-    
+  where 
+    new_wloc | isGiven wfl = getWantedLoc ifl
+             | otherwise   = getWantedLoc wfl
 
-doInteractWithInert ii@(CFunEqCan { cc_flavor = fl1, cc_fun = tc1
+doInteractWithInert ii@(CFunEqCan { cc_ev = fl1, cc_fun = tc1
                                   , cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 }) 
-                    wi@(CFunEqCan { cc_flavor = fl2, cc_fun = tc2
+                    wi@(CFunEqCan { cc_ev = fl2, cc_fun = tc2
                                   , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 })
+{-  ToDo: Check with Dimitrios
   | lhss_match  
   , isSolved fl1 -- Inert is solved and we can simply ignore it
                  -- when workitem is given/solved
-  , isGivenOrSolved fl2
+  , isGiven fl2
   = irInertConsumed "FunEq/FunEq"
   | lhss_match
   , isSolved fl2 -- Workitem is solved and we can ignore it when
                  -- the inert is given/solved
-  , isGivenOrSolved fl1                 
+  , isGiven fl1                 
   = irWorkItemConsumed "FunEq/FunEq" 
+-}
+
   | fl1 `canSolve` fl2 && lhss_match
   = do { traceTcS "interact with inerts: FunEq/FunEq" $ 
          vcat [ text "workItem =" <+> ppr wi
@@ -836,10 +831,12 @@ doInteractWithInert ii@(CFunEqCan { cc_flavor = fl1, cc_fun = tc1
              -- xdecomp : (F args ~ xi2) -> [(xi2 ~ xi1)]                 
              xdecomp x = [EvCoercion (mk_sym_co x `mkTcTransCo` co1)]
 
-       ; xCtFlavor_cache False fl2 [mkTcEqPred xi2 xi1] xev $ what_next d2
+       ; ctevs <- xCtFlavor_cache False fl2 [mkTcEqPred xi2 xi1] xev
                          -- Why not simply xCtFlavor? See Note [Cache-caused loops]
                          -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation]
+       ; add_to_work d2 ctevs 
        ; irWorkItemConsumed "FunEq/FunEq" }
+
   | fl2 `canSolve` fl1 && lhss_match
   = do { traceTcS "interact with inerts: FunEq/FunEq" $ 
          vcat [ text "workItem =" <+> ppr wi
@@ -847,25 +844,26 @@ doInteractWithInert ii@(CFunEqCan { cc_flavor = fl1, cc_fun = tc1
 
        ; let xev = XEvTerm xcomp xdecomp
               -- xcomp : [(xi2 ~ xi1)] -> [(F args ~ xi1)]
-             xcomp [x] = EvCoercion (co2 `mkTcTransCo` mkTcCoVarCo x)
+             xcomp [x] = EvCoercion (co2 `mkTcTransCo` evTermCoercion x)
              xcomp _ = panic "No more goals!"
              -- xdecomp : (F args ~ xi1) -> [(xi2 ~ xi1)]
-             xdecomp x = [EvCoercion (mkTcSymCo co2 `mkTcTransCo` mkTcCoVarCo x)]
+             xdecomp x = [EvCoercion (mkTcSymCo co2 `mkTcTransCo` evTermCoercion x)]
 
-       ; xCtFlavor_cache False fl1 [mkTcEqPred xi2 xi1] xev $ what_next d1
+       ; ctevs <- xCtFlavor_cache False fl1 [mkTcEqPred xi2 xi1] xev 
                           -- Why not simply xCtFlavor? See Note [Cache-caused loops]
                           -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation]
 
+       ; add_to_work d1 ctevs 
        ; irInertConsumed "FunEq/FunEq"}
   where
+    add_to_work d [ctev] = updWorkListTcS $ extendWorkListEq $
+                           CNonCanonical {cc_ev = ctev, cc_depth = d}
+    add_to_work _ _ = return ()
+
     lhss_match = tc1 == tc2 && eqTypes args1 args2 
-    what_next d [new_fl] 
-      = updWorkListTcS $ 
-        extendWorkListEq (CNonCanonical {cc_flavor=new_fl,cc_depth = d})
-    what_next _ _ = return ()
-    co1 = mkTcCoVarCo $ flav_evar fl1
-    co2 = mkTcCoVarCo $ flav_evar fl2
-    mk_sym_co x = mkTcSymCo (mkTcCoVarCo x)
+    co1 = evTermCoercion $ ctEvTerm fl1
+    co2 = evTermCoercion $ ctEvTerm fl2
+    mk_sym_co x = mkTcSymCo (evTermCoercion x)
     
 doInteractWithInert _ _ = irKeepGoing "NOP"
 
@@ -905,7 +903,7 @@ solving.
 \begin{code}
 
 solveOneFromTheOther :: String    -- Info 
-                     -> CtFlavor  -- Inert 
+                     -> CtEvidence  -- Inert 
                      -> Ct        -- WorkItem 
                      -> TcS InteractResult
 -- Preconditions: 
@@ -920,22 +918,23 @@ solveOneFromTheOther info ifl workItem
 		  -- so it's safe to continue on from this point
   = irInertConsumed ("Solved[DI] " ++ info)
   
-  | isSolved ifl, isGivenOrSolved wfl
+{-  ToDo: Check with Dimitrios
+  | isSolved ifl, isGiven wfl
     -- Same if the inert is a GivenSolved -- just get rid of it
   = irInertConsumed ("Solved[SI] " ++ info)
+-}
 
   | otherwise
   = ASSERT( ifl `canSolve` wfl )
       -- Because of Note [The Solver Invariant], plus Derived dealt with
-    do { when (isWanted wfl) $ setEvBind wid (EvId iid)
+    do { case wfl of
+           Wanted { ctev_evar = ev_id } -> setEvBind ev_id (ctEvTerm ifl)
+           _                            -> return ()
            -- Overwrite the binding, if one exists
 	   -- If both are Given, we already have evidence; no need to duplicate
        ; irWorkItemConsumed ("Solved " ++ info) }
   where 
-     wfl = cc_flavor workItem
-     wid = ctId workItem
-     iid = flav_evar ifl
-
+     wfl = cc_ev workItem
 \end{code}
 
 Note [Superclasses and recursive dictionaries]
@@ -1305,7 +1304,7 @@ now!).
 rewriteWithFunDeps :: [Equation]
                    -> [Xi] 
                    -> WantedLoc 
-                   -> TcS (Maybe ([Xi], [TcCoercion], [(EvVar,WantedLoc)])) 
+                   -> TcS (Maybe ([Xi], [CtEvidence])) 
                                            -- Not quite a WantedEvVar unfortunately
                                            -- Because our intention could be to make 
                                            -- it derived at the end of the day
@@ -1313,13 +1312,13 @@ rewriteWithFunDeps :: [Equation]
 -- 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))]
+      ; let fd_ev_pos :: [(Int,CtEvidence)]
             fd_ev_pos = concat fd_ev_poss
-            (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis)
+            rewritten_xis = rewriteDictParams fd_ev_pos xis
       ; if null fd_ev_pos then return Nothing
-        else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) }
+        else return (Just (rewritten_xis, map snd fd_ev_pos)) }
 
-instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))]
+instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,CtEvidence)]
 -- Post: Returns the position index as well as the corresponding FunDep equality
 instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
                         , fd_pred1 = d1, fd_pred2 = d2 })
@@ -1332,10 +1331,10 @@ 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 { mb_eqv <- newWantedEvVar (mkTcEqPred sty1 sty2)
+            else do { mb_eqv <- newDerived (push_ctx wl) (mkTcEqPred sty1 sty2)
                     ; case mb_eqv of
-                         Fresh eqv -> return $ (i,(eqv, push_ctx wl)):ievs
-                         Cached {} -> return ievs }
+                         Just ctev -> return $ (i,ctev):ievs
+                         Nothing   -> return ievs }
                            -- 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!
@@ -1355,34 +1354,30 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
 			  nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])]
 	; return (tidy_env, msg) }
 
-rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty)
-                  -> [Type]                    -- A sequence of types: tys
-                  -> [(Type, TcCoercion)]      -- Returns: [(ty', co : ty' ~ ty)]
+rewriteDictParams :: [(Int,CtEvidence)] -- A set of coercions : (pos, ty' ~ ty)
+                  -> [Type]             -- A sequence of types: tys
+                  -> [Type]                   
 rewriteDictParams param_eqs tys
   = zipWith do_one tys [0..]
   where
-    do_one :: Type -> Int -> (Type, TcCoercion)
+    do_one :: Type -> Int -> Type
     do_one ty n = case lookup n param_eqs of
-                    Just wev -> (get_fst_ty wev, mkTcCoVarCo (fst wev))
-                    Nothing  -> (ty,             mkTcReflCo ty)	-- Identity
+                    Just wev -> get_fst_ty wev
+                    Nothing  -> ty
 
-    get_fst_ty (wev,_wloc) 
-      | Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev )
+    get_fst_ty ctev
+      | Just (ty1, _) <- getEqPredTys_maybe (ctEvPred ctev)
       = ty1
       | otherwise 
       = panic "rewriteDictParams: non equality fundep!?"
 
         
-emitFDWorkAsDerived :: [(EvVar,WantedLoc)] 
+emitFDWorkAsDerived :: [CtEvidence]   -- All Derived
                     -> SubGoalDepth -> TcS () 
 emitFDWorkAsDerived evlocs d 
-  = updWorkListTcS $ appendWorkListEqs fd_cts
-  where fd_cts = map mk_fd_ct evlocs 
-        mk_fd_ct (v,wl) 
-          = CNonCanonical { cc_flavor = Derived wl (evVarPred v) 
-                          , cc_depth = d }
-
-
+  = updWorkListTcS $ appendWorkListEqs (map mk_fd_ct evlocs)
+  where 
+    mk_fd_ct der_ev = CNonCanonical { cc_ev = der_ev, cc_depth = d }
 \end{code}
 
 
@@ -1432,11 +1427,11 @@ doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
 
 -- Given dictionary
 -- See Note [Given constraint that matches an instance declaration]
-doTopReact _inerts (CDictCan { cc_flavor = Given {} })
+doTopReact _inerts (CDictCan { cc_ev = Given {} })
   = return NoTopInt -- NB: Superclasses already added since it's canonical
 
 -- Derived dictionary: just look for functional dependencies
-doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc _pty
+doTopReact _inerts workItem@(CDictCan { cc_ev = Derived loc _pty
                                       , cc_class = cls, cc_tyargs = xis })
   = do { instEnvs <- getInstEnvs
        ; let fd_eqns = improveFromInstEnv instEnvs
@@ -1444,7 +1439,7 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc _pty
        ; m <- rewriteWithFunDeps fd_eqns xis loc
        ; case m of
            Nothing -> return NoTopInt
-           Just (xis',_,fd_work) ->
+           Just (xis', fd_work) ->
                let workItem' = workItem { cc_tyargs = xis' }
                    -- Deriveds are not supposed to have identity
                in do { emitFDWorkAsDerived fd_work (cc_depth workItem)
@@ -1454,7 +1449,7 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc _pty
        }
 
 -- Wanted dictionary
-doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc dict_id)
+doTopReact inerts workItem@(CDictCan { cc_ev = fl@(Wanted { ctev_wloc = loc, ctev_evar = dict_id })
                                      , cc_class = cls, cc_tyargs = xis
                                      , cc_depth = depth })
   -- See Note [MATCHING-SYNONYMS]
@@ -1470,108 +1465,103 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc dict_id)
            Nothing ->
                do { lkup_inst_res  <- matchClassInst inerts cls xis loc
                   ; case lkup_inst_res of
-                      GenInst wtvs ev_term
-                          -> let sfl = Solved (mkSolvedLoc loc UnkSkol) dict_id 
-                             in addToSolved (workItem { cc_flavor = sfl }) >> 
-                                doSolveFromInstance wtvs ev_term
-                      NoInstance
-                          -> return NoTopInt
+                      GenInst wtvs ev_term -> do { addToSolved fl
+                                                 ; doSolveFromInstance wtvs ev_term }
+                      NoInstance -> return NoTopInt
                   }
            -- Actual Functional Dependencies
-           Just (_xis',_cos,fd_work) ->
+           Just (_xis', fd_work) ->
                do { emitFDWorkAsDerived fd_work (cc_depth workItem)
                   ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)"
                                       , tir_new_item = ContinueWith workItem } } }
 
-   where doSolveFromInstance :: [EvVar] -> EvTerm -> TcS TopInteractResult
-         -- Precondition: evidence term matches the predicate workItem
-         doSolveFromInstance evs ev_term 
-            | null evs
-            = do { traceTcS "doTopReact/found nullary instance for" $
-                   ppr dict_id
-                 ; setEvBind dict_id ev_term
-                 ; return $ 
-                   SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" 
-                              , tir_new_item = Stop } }
-            | otherwise 
-            = do { traceTcS "doTopReact/found non-nullary instance for" $ 
-                   ppr dict_id
-                 ; setEvBind dict_id ev_term
-                 ; let mk_new_wanted ev
-                           = CNonCanonical { cc_flavor = fl { flav_evar = ev }
-                                           , cc_depth  = depth + 1 }
-                 ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs))
-                 ; return $
-                   SomeTopInt { tir_rule     = "Dict/Top (solved, more work)"
-                              , tir_new_item = Stop }
-                 }
+   where 
+     doSolveFromInstance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult
+      -- Precondition: evidence term matches the predicate workItem
+     doSolveFromInstance evs ev_term 
+        | null evs
+        = do { traceTcS "doTopReact/found nullary instance for" $
+               ppr dict_id
+             ; setEvBind dict_id ev_term
+             ; return $ 
+               SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" 
+                          , tir_new_item = Stop } }
+        | otherwise 
+        = do { traceTcS "doTopReact/found non-nullary instance for" $ 
+               ppr dict_id
+             ; setEvBind dict_id ev_term
+             ; let mk_new_wanted ev
+                       = CNonCanonical { cc_ev   = ev
+                                       , cc_depth = depth + 1 }
+             ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs))
+             ; return $
+               SomeTopInt { tir_rule     = "Dict/Top (solved, more work)"
+                          , tir_new_item = Stop }
+             }
 
 -- Type functions
-doTopReact _inerts (CFunEqCan { cc_flavor = fl })
+{-  ToDo: Check with Dimitrios
+doTopReact _inerts (CFunEqCan { cc_ev = fl })
   | isSolved fl
   = return NoTopInt -- If Solved, no more interactions should happen
+-}
 
 -- Otherwise, it's a Given, Derived, or Wanted
-doTopReact _inerts workItem@(CFunEqCan { cc_flavor = fl, cc_depth = d
+doTopReact _inerts workItem@(CFunEqCan { cc_ev = fl, cc_depth = d
                                        , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
   = ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far 
     do { match_res <- matchFam tc args   -- See Note [MATCHING-SYNONYMS]
        ; case match_res of
            Nothing -> return NoTopInt 
            Just (famInst, rep_tys)
-             -> do { mb_already_solved <- lkpFunEqCache (mkTyConApp tc args)
+             -> do { mb_already_solved <- lkpSolvedFunEqCache (mkTyConApp tc args)
                    ; traceTcS "doTopReact: Family instance matches" $ 
                      vcat [ text "solved-fun-cache" <+> if isJust mb_already_solved then text "hit" else text "miss"
                           , text "workItem =" <+> ppr workItem ]
                    ; let (coe,rhs_ty) 
-                           | Just cached_ct <- mb_already_solved
-                           = (mkTcCoVarCo (ctId cached_ct), 
-                                  cc_rhs cached_ct)
+                           | Just ctev <- mb_already_solved
+                           , not (isDerived ctev)
+                           = ASSERT( isEqPred (ctEvPred ctev) )
+                             (evTermCoercion (ctEvTerm ctev), snd (getEqPredTys (ctEvPred ctev)))
                            | otherwise 
                            = let coe_ax = famInstAxiom famInst
                              in (mkTcAxInstCo coe_ax rep_tys, 
                                               mkAxInstRHS coe_ax rep_tys)
                                 
-                         xdecomp x = [EvCoercion (mkTcSymCo coe `mkTcTransCo` mkTcCoVarCo x)]
-                         xcomp [x] = EvCoercion (coe `mkTcTransCo` mkTcCoVarCo x)
+                         xdecomp x = [EvCoercion (mkTcSymCo coe `mkTcTransCo` evTermCoercion x)]
+                         xcomp [x] = EvCoercion (coe `mkTcTransCo` evTermCoercion x)
                          xcomp _   = panic "No more goals!"
                          
                          xev = XEvTerm xcomp xdecomp
-                   ; xCtFlavor fl [mkTcEqPred rhs_ty xi] xev what_next } }
-    where what_next [ct_flav]
-            = do { updWorkListTcS $ 
-                   extendWorkListEq (CNonCanonical { cc_flavor = ct_flav
-                                                   , cc_depth  = d+1 })
-                 ; cache_in_solved fl
-                 ; return $ SomeTopInt { tir_rule = "Fun/Top"
-                                       , tir_new_item = Stop } }
-          what_next _ -- No subgoal (because it's cached)
-            = do { cache_in_solved fl
-                 ; return $ SomeTopInt { tir_rule = "Fun/Top"
-                                       , tir_new_item = Stop } }
-
-          cache_in_solved (Derived {})   = return ()
-          cache_in_solved (Wanted wl ev) = 
-            let sfl = Solved (mkSolvedLoc wl UnkSkol) ev  
-                solved = workItem { cc_flavor = sfl }
-            in updFunEqCache solved >> addToSolved solved
-          cache_in_solved fl =
-            let sfl = Solved (flav_gloc fl) (flav_evar fl)
-                solved = workItem { cc_flavor = sfl }
-            in updFunEqCache solved >> addToSolved solved
+                   ; ctevs <- xCtFlavor fl [mkTcEqPred rhs_ty xi] xev
+                   ; case ctevs of
+                       [ctev] -> updWorkListTcS $ extendWorkListEq $
+                                 CNonCanonical { cc_ev = ctev
+                                               , cc_depth  = d+1 }
+                       ctevs -> -- No subgoal (because it's cached)
+                                ASSERT( null ctevs) return () 
+
+                   ; unless (isDerived fl) $
+                     do { addSolvedFunEq fl
+                        ; addToSolved fl }
+                   ; return $ SomeTopInt { tir_rule = "Fun/Top"
+                                       , tir_new_item = Stop } } }
             
 -- Any other work item does not react with any top-level equations
 doTopReact _inerts _workItem = return NoTopInt 
 
 
-lkpFunEqCache :: TcType -> TcS (Maybe Ct)
-lkpFunEqCache fam_head 
+lkpSolvedFunEqCache :: TcType -> TcS (Maybe CtEvidence)
+lkpSolvedFunEqCache fam_head 
   = do { (_subst,_inscope) <- getInertEqs 
        ; fun_cache <- getTcSInerts >>= (return . inert_solved_funeqs)
        ; traceTcS "lkpFunEqCache" $ vcat [ text "fam_head    =" <+> ppr fam_head
-                                         , text "funeq cache =" <+> pprCtTypeMap (unCtFamHeadMap fun_cache) ]
-       ; rewrite_cached $ 
-         lookupTM fam_head (unCtFamHeadMap fun_cache) }
+                                         , text "funeq cache =" <+> ppr fun_cache ]
+       ; return (lookupFamHead fun_cache fam_head) }
+
+{-             ToDo; talk to Dimitrios.  I have no idea what is happening here
+
+       ; rewrite_cached (lookupFamHead fun_cache fam_head) }
 -- The two different calls do not seem to make a significant difference in 
 -- terms of hit/miss rate for many memory-critical/performance tests but the
 -- latter blows up the space on the heap somehow ... It maybe the niFixTvSubst.
@@ -1579,11 +1569,10 @@ lkpFunEqCache fam_head
 --       lookupTypeMap_mod subst cc_rhs fam_head (unCtFamHeadMap fun_cache) }
  
   where rewrite_cached Nothing = return Nothing
-        rewrite_cached (Just ct@(CFunEqCan { cc_flavor = fl, cc_depth = d
+        rewrite_cached (Just ct@(CFunEqCan { cc_ev = fl, cc_depth = d
                                            , cc_fun = tc, cc_tyargs = xis
                                            , cc_rhs = xi}))
-          = ASSERT (isSolved fl)
-            do { (xis_subst,cos) <- flattenMany d FMFullFlatten fl xis 
+          = do { (xis_subst,cos) <- flattenMany d FMFullFlatten fl xis 
                                     -- cos :: xis_subst ~ xis 
                ; (xi_subst,co) <- flatten d FMFullFlatten fl xi
                                     -- co :: xi_subst ~ xi
@@ -1607,27 +1596,14 @@ lkpFunEqCache fam_head
                       -> return Nothing -- Strange: cached?
                     Just fl' 
                       -> return $ 
-                         Just (CFunEqCan { cc_flavor = fl'
+                         Just (CFunEqCan { cc_ev = fl'
                                          , cc_depth = d
                                          , cc_fun = tc
                                          , cc_tyargs = xis_subst
                                          , cc_rhs = xi_subst }) }
         rewrite_cached (Just other_ct) 
           = pprPanic "lkpFunEqCache:not family equation!" $ ppr other_ct
-
-updFunEqCache :: Ct -> TcS ()
-updFunEqCache fun_eq@(CFunEqCan { cc_fun = tc, cc_tyargs = xis })
-  = modifyInertTcS $ \inert -> ((), upd_inert inert)
-  where upd_inert inert 
-          = let slvd = unCtFamHeadMap (inert_solved_funeqs inert)
-            in inert { inert_solved_funeqs =
-                          CtFamHeadMap (alterTM key upd_funeqs slvd) }       
-        upd_funeqs Nothing    = Just fun_eq
-        upd_funeqs (Just _ct) = Just fun_eq 
-             -- Or _ct? depends on which caches more steps of computation
-        key = mkTyConApp tc xis
-updFunEqCache other = pprPanic "updFunEqCache:Non family equation" $ ppr other
-
+-}
 \end{code}
 
 
@@ -1830,7 +1806,7 @@ NB: The desugarer needs be more clever to deal with equalities
 \begin{code}
 data LookupInstResult
   = NoInstance
-  | GenInst [EvVar] EvTerm 
+  | GenInst [CtEvidence] EvTerm 
 
 matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult
 
@@ -1875,12 +1851,11 @@ matchClassInst inerts clas tys loc
                  ; if null theta then
                        return (GenInst [] (EvDFunApp dfun_id tys []))
                    else do
-                     { evc_vars <- instDFunConstraints theta
-                     ; let ev_vars = map mn_thing evc_vars
-                           new_ev_vars = [mn_thing evc | evc <- evc_vars
-                                                       , isFresh evc ]
+                     { evc_vars <- instDFunConstraints loc theta
+                     ; let new_ev_vars = freshGoals evc_vars
                            -- new_ev_vars are only the real new variables that can be emitted 
-                     ; return $ GenInst new_ev_vars (EvDFunApp dfun_id tys ev_vars) } }
+                           dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
+                     ; return $ GenInst new_ev_vars dfun_app } }
         }
    where 
      givens_for_this_clas :: Cts
@@ -1892,7 +1867,7 @@ matchClassInst inerts clas tys loc
      given_overlap untch = anyBag (matchable untch) givens_for_this_clas
 
      matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys
-                               , cc_flavor = fl })
+                               , cc_ev = fl })
        | isGiven fl
        = ASSERT( clas_g == clas )
          case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv && 
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 3ba80e3b0f..79b6b02950 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -627,29 +627,24 @@ zonkWC (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 { fl' <- zonkFlavor (cc_flavor ct)
+  = do { fl' <- zonkCtEvidence (cc_ev ct)
        ; return $ 
-         CNonCanonical { cc_flavor = fl'
+         CNonCanonical { cc_ev = fl'
                        , cc_depth = cc_depth ct } }
 zonkCts :: Cts -> TcM Cts
 zonkCts = mapBagM zonkCt
 
-zonkFlavor :: CtFlavor -> TcM CtFlavor
-zonkFlavor (Given loc evar) 
+zonkCtEvidence :: CtEvidence -> TcM CtEvidence
+zonkCtEvidence ctev@(Given { ctev_gloc = loc, ctev_pred = pred }) 
   = do { loc' <- zonkGivenLoc loc
-       ; evar' <- zonkEvVar evar
-       ; return (Given loc' evar') }
-zonkFlavor (Solved loc evar) 
-  = do { loc' <- zonkGivenLoc loc
-       ; evar' <- zonkEvVar evar
-       ; return (Solved loc' evar') }
-zonkFlavor (Wanted loc evar)
-  = do { evar' <- zonkEvVar evar
-       ; return (Wanted loc evar') }
-zonkFlavor (Derived loc pty)
-  = do { pty' <- zonkTcType pty
-       ; return (Derived loc pty') }
-
+       ; pred' <- zonkTcType pred
+       ; return (ctev { ctev_gloc = loc', ctev_pred = pred'}) }
+zonkCtEvidence ctev@(Wanted { ctev_pred = pred })
+  = do { pred' <- zonkTcType pred
+       ; return (ctev { ctev_pred = pred' }) }
+zonkCtEvidence ctev@(Derived { ctev_pred = pred })
+  = do { pred' <- zonkTcType pred
+       ; return (ctev { ctev_pred = pred' }) }
 
 zonkGivenLoc :: GivenLoc -> TcM GivenLoc
 -- GivenLocs may have unification variables inside them!
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index acdc8389be..2941a17092 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -31,7 +31,6 @@ import TcMType
 import TcType
 import TcBinds
 import TcUnify
-import TcErrors         ( misMatchMsg )
 import Name
 import TysWiredIn
 import Id
@@ -398,21 +397,21 @@ tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside
 	; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
 
 -- ParStmt: See notes with tcMcStmt
-tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
+tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _) elt_ty thing_inside
   = do	{ (pairs', thing) <- loop bndr_stmts_s
-	; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) }
+	; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr, thing) }
   where
     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
     loop [] = do { thing <- thing_inside elt_ty
 		 ; return ([], thing) }		-- matching in the branches
 
-    loop ((stmts, names) : pairs)
+    loop (ParStmtBlock stmts names _ : pairs)
       = do { (stmts', (ids, pairs', thing))
 		<- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
 		   do { ids <- tcLookupLocalIds names
 		      ; (pairs', thing) <- loop pairs
 		      ; return (ids, pairs', thing) }
-	   ; return ( (stmts', ids) : pairs', thing ) }
+	   ; return ( ParStmtBlock stmts' ids noSyntaxExpr : pairs', thing ) }
 
 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
                               , trS_bndrs =  bindersMap
@@ -675,7 +674,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
 --        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
 --        -> m (st1, (st2, st3))
 --
-tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside
+tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside
   = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind
        ; m_ty   <- newFlexiTyVarTy star_star_kind
 
@@ -687,14 +686,10 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi
                         (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
        ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
 
-       ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $
-                       mkForAllTy alphaTyVar $
-                       alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy)
-
-       ; (pairs', thing) <- loop m_ty bndr_stmts_s
+       ; (blocks', thing) <- loop m_ty bndr_stmts_s
 
        -- Typecheck bind:
-       ; let tys      = map (mkBigCoreVarTupTy . snd) pairs'
+       ; let tys      = [ mkBigCoreVarTupTy bs | ParStmtBlock _ bs _ <- blocks']
              tuple_ty = mk_tuple_ty tys
 
        ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
@@ -702,7 +697,7 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi
                         `mkFunTy` (tuple_ty `mkFunTy` res_ty)
                         `mkFunTy` res_ty
 
-       ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) }
+       ; return (ParStmt blocks' mzip_op' bind_op', thing) }
 
   where 
     mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
@@ -713,31 +708,19 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_insi
     loop _ [] = do { thing <- thing_inside res_ty
                    ; return ([], thing) }           -- matching in the branches
 
-    loop m_ty ((stmts, names) : pairs)
+    loop m_ty (ParStmtBlock stmts names return_op : pairs)
       = do { -- type dummy since we don't know all binder types yet
-             ty_dummy <- newFlexiTyVarTy liftedTypeKind
-           ; (stmts', (ids, pairs', thing))
-                <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' ->
+             id_tys <- mapM (const (newFlexiTyVarTy liftedTypeKind)) names
+           ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreTupTy id_tys
+           ; (stmts', (ids, return_op', pairs', thing))
+                <- tcStmtsAndThen ctxt tcMcStmt stmts m_tup_ty $ \m_tup_ty' ->
                    do { ids <- tcLookupLocalIds names
-    		      ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids
-
-    		      ; check_same m_tup_ty res_ty'
-    		      ; check_same m_tup_ty ty_dummy
-    							 
+    		      ; let tup_ty = mkBigCoreVarTupTy ids
+                      ; return_op' <- tcSyntaxOp MCompOrigin return_op
+                                          (tup_ty `mkFunTy` m_tup_ty')
                       ; (pairs', thing) <- loop m_ty pairs
-                      ; return (ids, pairs', thing) }
-           ; return ( (stmts', ids) : pairs', thing ) }
-
-	-- Check that the types match up.
-	-- This is a grevious hack.  They always *will* match 
-	-- If (>>=) and (>>) are polymorpic in the return type,
-	-- but we don't have any good way to incorporate the coercion
-	-- so for now we just check that it's the identity
-    check_same actual expected
-      = do { co <- unifyType actual expected
-	   ; unless (isTcReflCo co) $
-             failWithMisMatch [UnifyOrigin { uo_expected = expected
-                                           , uo_actual = actual }] }
+                      ; return (ids, return_op', pairs', thing) }
+           ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }
 
 tcMcStmt _ stmt _ _
   = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
@@ -877,22 +860,5 @@ checkArgs fun (MatchGroup (match1:matches) _)
     args_in_match :: LMatch Name -> Int
     args_in_match (L _ (Match pats _ _)) = length pats
 checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty
-
-failWithMisMatch :: [EqOrigin] -> TcM a
--- Generate the message when two types fail to match,
--- going to some trouble to make it helpful.
--- We take the failing types from the top of the origin stack
--- rather than reporting the particular ones we are looking 
--- at right now
-failWithMisMatch (item:origin)
-  = wrapEqCtxt origin $
-    do	{ ty_act <- zonkTcType (uo_actual item)
-        ; ty_exp <- zonkTcType (uo_expected item)
-        ; env0 <- tcInitTidyEnv
-        ; let (env1, pp_exp) = tidyOpenType env0 ty_exp
-              (env2, pp_act) = tidyOpenType env1 ty_act
-        ; failWithTcM (env2, misMatchMsg True pp_exp pp_act) }
-failWithMisMatch [] 
-  = panic "failWithMisMatch"
 \end{code}
 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 6a79b738fd..d17d3e6a10 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -55,9 +55,9 @@ module TcRnTypes(
         singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan,
         isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe,
         isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, 
-        isGivenCt, isGivenOrSolvedCt,
-        ctWantedLoc,
-        SubGoalDepth, mkNonCanonical, ctPred, ctFlavPred, ctId, ctFlavId,
+        isGivenCt, 
+        ctWantedLoc, ctEvidence,
+        SubGoalDepth, mkNonCanonical, ctPred, ctEvPred, ctEvTerm, ctEvId,
 
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
         andWC, addFlats, addImplics, mkFlatWC,
@@ -70,9 +70,9 @@ module TcRnTypes(
 
 	SkolemInfo(..),
 
-        CtFlavor(..), pprFlavorArising,
-        mkSolvedLoc, mkGivenLoc,
-        isWanted, isGivenOrSolved, isGiven, isSolved,
+        CtEvidence(..), pprFlavorArising,
+        mkGivenLoc,
+        isWanted, isGiven,
         isDerived, getWantedLoc, getGivenLoc, canSolve, canRewrite,
 
 	-- Pretty printing
@@ -89,7 +89,7 @@ module TcRnTypes(
 
 import HsSyn
 import HscTypes
-import TcEvidence( EvBind, EvBindsVar )
+import TcEvidence
 import Type
 import Class    ( Class )
 import TyCon    ( TyCon )
@@ -850,7 +850,7 @@ type SubGoalDepth = Int -- An ever increasing number used to restrict
 data Ct
   -- Atomic canonical constraints 
   = CDictCan {  -- e.g.  Num xi
-      cc_flavor :: CtFlavor, 
+      cc_ev :: CtEvidence, 
       cc_class  :: Class, 
       cc_tyargs :: [Xi],
 
@@ -860,14 +860,14 @@ data Ct
 
   | CIPCan {	-- ?x::tau
       -- See note [Canonical implicit parameter constraints].
-      cc_flavor :: CtFlavor,
+      cc_ev :: CtEvidence,
       cc_ip_nm  :: IPName Name,
-      cc_ip_ty  :: TcTauType, -- Not a Xi! See same not as above
+      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_flavor :: CtFlavor,
+      cc_ev :: CtEvidence,
       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
@@ -881,7 +881,7 @@ data Ct
        --   * typeKind xi `compatKind` typeKind tv
        --       See Note [Spontaneous solving and kind compatibility]
        --   * We prefer unification variables on the left *JUST* for efficiency
-      cc_flavor :: CtFlavor, 
+      cc_ev :: CtEvidence, 
       cc_tyvar  :: TcTyVar, 
       cc_rhs    :: Xi,
 
@@ -891,7 +891,7 @@ data Ct
   | CFunEqCan {  -- F xis ~ xi  
                  -- Invariant: * isSynFamilyTyCon cc_fun 
                  --            * typeKind (F xis) `compatKind` typeKind xi
-      cc_flavor :: CtFlavor, 
+      cc_ev :: CtEvidence, 
       cc_fun    :: TyCon,	-- A type function
       cc_tyargs :: [Xi],	-- Either under-saturated or exactly saturated
       cc_rhs    :: Xi,      	--    *never* over-saturated (because if so
@@ -902,18 +902,24 @@ data Ct
     }
 
   | CNonCanonical { -- See Note [NonCanonical Semantics] 
-      cc_flavor :: CtFlavor, 
+      cc_ev :: CtEvidence, 
       cc_depth  :: SubGoalDepth
     }
 
 \end{code}
 
 \begin{code}
-mkNonCanonical :: CtFlavor -> Ct
-mkNonCanonical flav = CNonCanonical { cc_flavor = flav, cc_depth = 0}
+mkNonCanonical :: CtEvidence -> Ct
+mkNonCanonical flav = CNonCanonical { cc_ev = flav, cc_depth = 0}
+
+ctEvidence :: Ct -> CtEvidence
+ctEvidence = cc_ev
 
 ctPred :: Ct -> PredType 
-ctPred (CNonCanonical { cc_flavor = fl }) = ctFlavPred fl
+ctPred ct = ctEvPred (cc_ev ct)
+-- ToDo Check with Dimitrios
+{-
+ctPred (CNonCanonical { cc_ev = fl }) = ctEvPred fl
 ctPred (CDictCan { cc_class = cls, cc_tyargs = xis }) 
   = mkClassPred cls xis
 ctPred (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) 
@@ -923,18 +929,13 @@ ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 })
 ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi }) 
   = mkIPPred nm xi
 ctPred (CIrredEvCan { cc_ty = xi }) = xi
-
-
-ctId :: Ct -> EvVar
--- Precondition: not a derived!
-ctId ct = ctFlavId (cc_flavor ct)
-
+-}
 \end{code}
 
 
 %************************************************************************
 %*									*
-                    CtFlavor
+                    CtEvidence
          The "flavor" of a canonical constraint
 %*									*
 %************************************************************************
@@ -942,20 +943,17 @@ ctId ct = ctFlavId (cc_flavor ct)
 \begin{code}
 ctWantedLoc :: Ct -> WantedLoc
 -- Only works for Wanted/Derived
-ctWantedLoc ct = ASSERT2( not (isGivenOrSolved (cc_flavor ct)), ppr ct )
-                 getWantedLoc (cc_flavor ct)
+ctWantedLoc ct = ASSERT2( not (isGiven (cc_ev ct)), ppr ct )
+                 getWantedLoc (cc_ev ct)
 
 isWantedCt :: Ct -> Bool
-isWantedCt = isWanted . cc_flavor 
+isWantedCt = isWanted . cc_ev 
 
 isGivenCt :: Ct -> Bool
-isGivenCt = isGiven . cc_flavor
+isGivenCt = isGiven . cc_ev
 
 isDerivedCt :: Ct -> Bool
-isDerivedCt = isDerived . cc_flavor
-
-isGivenOrSolvedCt :: Ct -> Bool
-isGivenOrSolvedCt = isGivenOrSolved . cc_flavor
+isDerivedCt = isDerived . cc_ev
 
 isCTyEqCan :: Ct -> Bool 
 isCTyEqCan (CTyEqCan {})  = True 
@@ -989,7 +987,7 @@ isCNonCanonical _ = False
 
 \begin{code}
 instance Outputable Ct where
-  ppr ct = ppr (cc_flavor ct) <+> 
+  ppr ct = ppr (cc_ev ct) <+> 
            braces (ppr (cc_depth ct)) <+> parens (text ct_sort)
          where ct_sort = case ct of 
                            CTyEqCan {}      -> "CTyEqCan"
@@ -1229,86 +1227,80 @@ pprWantedsWithLocs wcs
 %*									*
 %************************************************************************
 
+Note [Evidence field of CtEvidence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+During constraint solving we never look at the type of ctev_evtm, or
+ctev_evar; instead we look at the cte_pred field.  The evtm/evar field
+may be un-zonked.
+
 \begin{code}
-data CtFlavor
-  = Given { flav_gloc :: GivenLoc, flav_evar :: EvVar } 
-    -- Trully given, not depending on subgoals
+data CtEvidence   -- Rename to CtEvidence
+  = Given { ctev_gloc :: GivenLoc
+          , ctev_pred :: TcPredType
+          , ctev_evtm :: EvTerm }          -- See Note [Evidence field of CtEvidence]
+    -- Truly given, not depending on subgoals
     -- NB: Spontaneous unifications belong here
     -- DV TODOs: (i)  Consider caching actual evidence _term_
     --           (ii) Revisit Note [Optimizing Spontaneously Solved Coercions]
     
-  | Solved { flav_gloc :: GivenLoc, flav_evar :: EvVar }
-    -- Originally wanted, but now we've produced and 
-    -- bound some partial evidence for this constraint.
-    -- NB: Evidence may rely on yet-wanted constraints or other solved or given
-    
-  | Wanted { flav_wloc :: WantedLoc, flav_evar :: EvVar }
+  | Wanted { ctev_wloc :: WantedLoc
+           , ctev_pred :: TcPredType
+           , ctev_evar :: EvVar }          -- See Note [Evidence field of CtEvidence]
     -- Wanted goal 
     
-  | Derived { flav_wloc :: WantedLoc, flav_der_pty :: TcPredType }
+  | Derived { ctev_wloc :: WantedLoc 
+            , ctev_pred :: TcPredType }
     -- A goal that we don't really have to solve and can't immediately 
-    -- rewrite anything other than a derived (there's no evidence variable!) 
+    -- rewrite anything other than a derived (there's no evidence!) 
     -- but if we do manage to solve it may help in solving other goals.
 
-ctFlavPred :: CtFlavor -> TcPredType
+ctEvPred :: CtEvidence -> TcPredType
 -- The predicate of a flavor
-ctFlavPred (Given _ evar)  = evVarPred evar
-ctFlavPred (Solved _ evar) = evVarPred evar
-ctFlavPred (Wanted _ evar) = evVarPred evar
-ctFlavPred (Derived { flav_der_pty = pty }) = pty
-
-ctFlavId :: CtFlavor -> EvVar
--- Precondition: can't be derived
-ctFlavId (Derived _ pty) 
-  = pprPanic "ctFlavId: derived constraint cannot have id" $ 
-    text "pty   =" <+> ppr pty
-ctFlavId fl = flav_evar fl
-
-instance Outputable CtFlavor where
+ctEvPred = ctev_pred
+
+ctEvTerm :: CtEvidence -> EvTerm
+ctEvTerm (Given   { ctev_evtm = tm }) = tm
+ctEvTerm (Wanted  { ctev_evar = ev }) = EvId ev
+ctEvTerm ctev@(Derived {}) = pprPanic "ctEvTerm: derived constraint cannot have id" 
+                                      (ppr ctev)
+
+ctEvId :: CtEvidence -> TcId
+ctEvId (Wanted  { ctev_evar = ev }) = ev
+ctEvId ctev = pprPanic "ctEvId:" (ppr ctev)
+
+instance Outputable CtEvidence where
   ppr fl = case fl of
-             (Given _ evar)  -> ptext (sLit "[G]") <+> ppr evar <+> ppr_pty
-             (Solved _ evar) -> ptext (sLit "[S]") <+> ppr evar <+> ppr_pty
-             (Wanted _ evar) -> ptext (sLit "[W]") <+> ppr evar <+> ppr_pty
-             (Derived {})    -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty
-         where ppr_pty = dcolon <+> ppr (ctFlavPred fl)
+             Given {}   -> ptext (sLit "[G]") <+> ppr (ctev_evtm fl) <+> ppr_pty
+             Wanted {}  -> ptext (sLit "[W]") <+> ppr (ctev_evar fl) <+> ppr_pty
+             Derived {} -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty
+         where ppr_pty = dcolon <+> ppr (ctEvPred fl)
 
-getWantedLoc :: CtFlavor -> WantedLoc
+getWantedLoc :: CtEvidence -> WantedLoc
 -- Precondition: Wanted or Derived
-getWantedLoc fl = flav_wloc fl
+getWantedLoc fl = ctev_wloc fl
 
-getGivenLoc :: CtFlavor -> GivenLoc 
--- Precondition: Given or Solved
-getGivenLoc fl = flav_gloc fl
+getGivenLoc :: CtEvidence -> GivenLoc 
+-- Precondition: Given
+getGivenLoc fl = ctev_gloc fl
 
-pprFlavorArising :: CtFlavor -> SDoc
-pprFlavorArising (Given gl _)   = pprArisingAt gl
-pprFlavorArising (Solved gl _)  = pprArisingAt gl
-pprFlavorArising (Wanted wl _)  = pprArisingAt wl
-pprFlavorArising (Derived wl _) = pprArisingAt wl
+pprFlavorArising :: CtEvidence -> SDoc
+pprFlavorArising (Given { ctev_gloc = gl }) = pprArisingAt gl
+pprFlavorArising ctev                       = pprArisingAt (ctev_wloc ctev)
 
 
-isWanted :: CtFlavor -> Bool
+isWanted :: CtEvidence -> Bool
 isWanted (Wanted {}) = True
 isWanted _ = False
 
-isGivenOrSolved :: CtFlavor -> Bool
-isGivenOrSolved (Given {})  = True
-isGivenOrSolved (Solved {}) = True
-isGivenOrSolved _ = False
-
-isSolved :: CtFlavor -> Bool
-isSolved (Solved {}) = True
-isSolved _ = False
-
-isGiven :: CtFlavor -> Bool 
-isGiven (Given {}) = True
+isGiven :: CtEvidence -> Bool
+isGiven (Given {})  = True
 isGiven _ = False
 
-isDerived :: CtFlavor -> Bool
+isDerived :: CtEvidence -> Bool
 isDerived (Derived {}) = True
 isDerived _             = False
 
-canSolve :: CtFlavor -> CtFlavor -> Bool
+canSolve :: CtEvidence -> CtEvidence -> Bool
 -- canSolve ctid1 ctid2 
 -- The constraint ctid1 can be used to solve ctid2 
 -- "to solve" means a reaction where the active parts of the two constraints match.
@@ -1325,18 +1317,13 @@ canSolve (Wanted {})  (Wanted {})  = True
 canSolve (Derived {}) (Derived {}) = True  -- Derived can't solve wanted/given
 canSolve _ _ = False  	       	     	   -- No evidence for a derived, anyway
 
-canRewrite :: CtFlavor -> CtFlavor -> Bool 
+canRewrite :: CtEvidence -> CtEvidence -> Bool 
 -- canRewrite ct1 ct2 
 -- The equality constraint ct1 can be used to rewrite inside ct2 
 canRewrite = canSolve 
 
-
 mkGivenLoc :: WantedLoc -> SkolemInfo -> GivenLoc
 mkGivenLoc wl sk = setCtLocOrigin wl sk
-
-mkSolvedLoc :: WantedLoc -> SkolemInfo -> GivenLoc
-mkSolvedLoc wl sk = setCtLocOrigin wl sk
-
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index ca7cf88fd1..7d86d157a0 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -24,15 +24,13 @@ module TcSMonad (
     Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts, 
     emitFrozenError,
 
-    isWanted, isGivenOrSolved, isDerived,
-    isGivenOrSolvedCt, isGivenCt, 
-    isWantedCt, isDerivedCt, pprFlavorArising,
+    isWanted, isDerived, 
+    isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
 
     isFlexiTcsTv,
 
     canRewrite, canSolve,
-    mkSolvedLoc, mkGivenLoc,
-    ctWantedLoc,
+    mkGivenLoc, ctWantedLoc,
 
     TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality 
     traceFireTcS, bumpStepCountTcS, doWithInert,
@@ -42,16 +40,17 @@ module TcSMonad (
     SimplContext(..), isInteractive, performDefaulting,
 
     -- Getting and setting the flattening cache
-    getFlatCache, updFlatCache, addToSolved, 
+    getFlatCache, updFlatCache, addToSolved, addSolvedFunEq,
     
     deferTcSForAllEq, 
     
     setEvBind,
     XEvTerm(..),
-    MaybeNew (..), isFresh,
-    xCtFlavor, -- Transform a CtFlavor during a step 
+    MaybeNew (..), isFresh, freshGoals, getEvTerms,
+
+    xCtFlavor, -- Transform a CtEvidence during a step 
     rewriteCtFlavor,          -- Specialized version of xCtFlavor for coercions
-    newWantedEvVar, newGivenEvVar, instDFunConstraints, newKindConstraint,
+    newWantedEvVar, instDFunConstraints, newKindConstraint,
     newDerived,
     xCtFlavor_cache, rewriteCtFlavor_cache,
     
@@ -68,12 +67,14 @@ module TcSMonad (
         -- Inerts 
     InertSet(..), InertCans(..), 
     getInertEqs, getCtCoercion,
-    emptyInert, getTcSInerts, lookupInInerts, updInertSet, extractUnsolved,
+    emptyInert, getTcSInerts, lookupInInerts, 
+    extractUnsolved,
     extractUnsolvedTcS, modifyInertTcS,
     updInertSetTcS, partitionCCanMap, partitionEqMap,
     getRelevantCts, extractRelevantInerts,
-    CCanMap (..), CtTypeMap, CtFamHeadMap(..), CtPredMap(..),
-    pprCtTypeMap, partCtFamHeadMap,
+    CCanMap(..), CtTypeMap, CtFamHeadMap, CtPredMap,
+    PredMap, FamHeadMap,
+    partCtFamHeadMap, lookupFamHead,
 
 
     instDFunType,                              -- Instantiation
@@ -136,14 +137,12 @@ import TcRnTypes
 
 import Unique 
 import UniqFM
-import Maybes ( orElse )
+import Maybes ( orElse, catMaybes )
 
 
-import Control.Monad( when )
+import Control.Monad( when, zipWithM )
 import StaticFlags( opt_PprStyle_Debug )
 import Data.IORef
-import Data.List ( find )
-import Control.Monad ( zipWithM )
 import TrieMap
 
 \end{code}
@@ -298,11 +297,10 @@ emptyCCanMap = CCanMap { cts_given = emptyUFM, cts_derived = emptyUFM, cts_wante
 
 updCCanMap:: Uniquable a => (a,Ct) -> CCanMap a -> CCanMap a 
 updCCanMap (a,ct) cmap 
-  = case cc_flavor ct of 
+  = case cc_ev 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) }
-      Solved {}  -> panic "updCCanMap update with solved!" 
   where 
     insert_into m = addToUFM_C unionBags m a (singleCt ct)
 
@@ -319,13 +317,24 @@ getRelevantCts a cmap
   where
     lookup map = lookupUFM map a `orElse` emptyCts
 
-lookupCCanMap :: Uniquable a => a -> (Ct -> Bool) -> CCanMap a -> Maybe Ct
-lookupCCanMap a p map
-   = let possible_cts = lookupUFM (cts_given map)   a `orElse` 
-                        lookupUFM (cts_wanted map)  a `orElse` 
-                        lookupUFM (cts_derived map) a `orElse` emptyCts
-     in find p (bagToList possible_cts)
+lookupCCanMap :: Uniquable a => a -> (CtEvidence -> Bool) -> CCanMap a -> Maybe CtEvidence
+lookupCCanMap a pick_me map
+  = findEvidence pick_me possible_cts
+  where
+     possible_cts = lookupUFM (cts_given map)   a `plus` (
+                    lookupUFM (cts_wanted map)  a `plus` (
+                    lookupUFM (cts_derived map) a `plus` emptyCts))
 
+     plus Nothing     cts2 = cts2
+     plus (Just cts1) cts2 = cts1 `unionBags` cts2
+
+findEvidence :: (CtEvidence -> Bool) -> Cts -> Maybe CtEvidence
+findEvidence pick_me cts
+  = foldrBag pick Nothing cts
+  where
+     pick :: Ct -> Maybe CtEvidence -> Maybe CtEvidence
+     pick ct deflt | let ctev = cc_ev ct, pick_me ctev = Just ctev
+                   | otherwise                             = deflt
 
 partitionCCanMap :: (Ct -> Bool) -> CCanMap a -> (Cts,CCanMap a) 
 -- All constraints that /match/ the predicate go in the bag, the rest remain in the map
@@ -360,27 +369,33 @@ extractUnsolvedCMap cmap =
 
 
 -- Maps from PredTypes to Constraints
-type CtTypeMap = TypeMap Ct
-newtype CtPredMap = 
-  CtPredMap { unCtPredMap :: CtTypeMap }       -- Indexed by TcPredType
-newtype CtFamHeadMap = 
-  CtFamHeadMap { unCtFamHeadMap :: CtTypeMap } -- Indexed by family head
+type CtTypeMap    = TypeMap    Ct
+type CtPredMap    = PredMap    Ct
+type CtFamHeadMap = FamHeadMap Ct
+
+newtype PredMap    a = PredMap    { unPredMap    :: TypeMap a } -- Indexed by TcPredType
+newtype FamHeadMap a = FamHeadMap { unFamHeadMap :: TypeMap a } -- Indexed by family head
 
-pprCtTypeMap :: TypeMap Ct -> SDoc 
-pprCtTypeMap ctmap = ppr (foldTM (:) ctmap [])
+instance Outputable a => Outputable (PredMap a) where
+   ppr (PredMap m) = ppr (foldTM (:) m [])
+
+instance Outputable a => Outputable (FamHeadMap a) where
+   ppr (FamHeadMap m) = ppr (foldTM (:) m [])
 
 ctTypeMapCts :: TypeMap Ct -> Cts
 ctTypeMapCts ctmap = foldTM (\ct cts -> extendCts cts ct) ctmap emptyCts
 
+lookupFamHead :: FamHeadMap a -> TcType -> Maybe a
+lookupFamHead (FamHeadMap m) key = lookupTM key m
 
 partCtFamHeadMap :: (Ct -> Bool) 
                  -> CtFamHeadMap 
                  -> (Cts, CtFamHeadMap)
 partCtFamHeadMap f ctmap
   = let (cts,tymap_final) = foldTM upd_acc tymap_inside (emptyBag, tymap_inside)
-    in (cts, CtFamHeadMap tymap_final)
+    in (cts, FamHeadMap tymap_final)
   where
-    tymap_inside = unCtFamHeadMap ctmap 
+    tymap_inside = unFamHeadMap ctmap 
     upd_acc ct (cts,acc_map)
          | f ct      = (extendCts cts ct, alterTM ct_key (\_ -> Nothing) acc_map)
          | otherwise = (cts,acc_map)
@@ -388,8 +403,6 @@ partCtFamHeadMap f ctmap
                       = ty1 
                       | otherwise 
                       = panic "partCtFamHeadMap, encountered non equality!"
-
-
 \end{code}
 
 %************************************************************************
@@ -400,9 +413,7 @@ partCtFamHeadMap f ctmap
 %************************************************************************
 
 \begin{code}
-
-
--- All Given (fully known) or Wanted or Derived, never Solved
+-- All Given (fully known) or Wanted or Derived
 -- See Note [Detailed InertCans Invariants] for more
 data InertCans 
   = IC { inert_eqs :: TyVarEnv Ct
@@ -467,29 +478,51 @@ The InertCans represents a collection of constraints with the following properti
          occurs errors. 
 
   9 Given family or dictionary constraints don't mention touchable unification variables
-\begin{code}
 
+Note [Solved constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+When we take a step to simplify a constraint 'c', we call the original constraint "solved".
+For example:   Wanted:    ev  :: [s] ~ [t]
+               New goal:  ev1 :: s ~ t
+               Then 'ev' is now "solved".
+
+The reason for all this is simply to avoid re-solving goals we have solved already.
+
+* A solved Wanted may depend on as-yet-unsolved goals, so (for example) we should not
+  use it to rewrite a Given; in that sense the solved goal is still a Wanted
+
+* A solved Given is just given
+
+* A solved Derived is possible; purpose is to avoid creating tons of identical
+  Derived goals.
 
+
+\begin{code}
 -- The Inert Set
 data InertSet
   = IS { inert_cans :: InertCans
-              -- Canonical Given,Wanted,Solved
+              -- Canonical Given, Wanted, Derived (no Solved)
+	      -- Sometimes called "the inert set"
+
        , inert_frozen :: Cts       
               -- Frozen errors (as non-canonicals)
                                
-       , inert_solved :: CtPredMap
-              -- Solved constraints (for caching): 
-              -- (i) key is by predicate type
-              -- (ii) all of 'Solved' flavor, may or may not be canonicals
-              -- (iii) we use this field for avoiding creating newEvVars
        , inert_flat_cache :: CtFamHeadMap 
               -- All ``flattening equations'' are kept here. 
               -- Always canonical CTyFunEqs (Given or Wanted only!)
-              -- Key is by family head. We used this field during flattening only
-       , inert_solved_funeqs :: CtFamHeadMap
-              -- Memoized Solved family equations co :: F xis ~ xi
-              -- Stored not necessarily as fully rewritten; we'll do that lazily
-              -- when we lookup
+              -- Key is by family head. We use this field during flattening only
+              -- Not necessarily inert wrt top-level equations (or inert_cans)
+
+       , inert_solved_funeqs :: FamHeadMap CtEvidence  -- Of form co :: F xis ~ xi
+       , inert_solved        :: PredMap    CtEvidence  -- All others
+       	      -- These two fields constitute a cache of solved (only!) constraints
+              -- See Note [Solved constraints]
+       	      -- - Constraints of form (F xis ~ xi) live in inert_solved_funeqs, 
+       	      --   all the others are in inert_solved
+       	      -- - Used to avoid creating a new EvVar when we have a new goal that we
+       	      --   have solvedin the past
+       	      -- - Stored not necessarily as fully rewritten 
+       	      --   (ToDo: rewrite lazily when we lookup)
        }
 
 
@@ -498,7 +531,7 @@ instance Outputable InertCans where
                  , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts ics)))
                  , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips ics))) 
                  , vcat (map ppr (Bag.bagToList $ 
-                                  ctTypeMapCts (unCtFamHeadMap $ inert_funeqs ics)))
+                                  ctTypeMapCts (unFamHeadMap $ inert_funeqs ics)))
                  , vcat (map ppr (Bag.bagToList $ inert_irreds ics))
                  ]
             
@@ -508,7 +541,7 @@ instance Outputable InertSet where
                     braces (vcat (map ppr (Bag.bagToList $ inert_frozen is)))
                 , text "Solved and cached" <+>
                     int (foldTypeMap (\_ x -> x+1) 0 
-                             (unCtPredMap $ inert_solved is)) <+> 
+                             (unPredMap $ inert_solved is)) <+> 
                     text "more constraints" ]
 
 emptyInert :: InertSet
@@ -517,28 +550,27 @@ emptyInert
                          , inert_eq_tvs = emptyInScopeSet
                          , inert_dicts  = emptyCCanMap
                          , inert_ips    = emptyCCanMap
-                         , inert_funeqs = CtFamHeadMap emptyTM 
+                         , inert_funeqs = FamHeadMap emptyTM 
                          , inert_irreds = emptyCts }
        , inert_frozen        = emptyCts
-       , inert_flat_cache    = CtFamHeadMap emptyTM
-       , inert_solved        = CtPredMap emptyTM 
-       , inert_solved_funeqs = CtFamHeadMap emptyTM }
+       , inert_flat_cache    = FamHeadMap emptyTM
+       , inert_solved        = PredMap emptyTM 
+       , inert_solved_funeqs = FamHeadMap emptyTM }
 
-type AtomicInert = Ct 
-
-updInertSet :: InertSet -> AtomicInert -> InertSet 
--- Add a new inert element to the inert set. 
-updInertSet is item 
-  | isSolved (cc_flavor item)
-    -- Solved items go in their special place
-  = let pty = ctPred item
+updSolvedSet :: InertSet -> CtEvidence -> InertSet 
+updSolvedSet is item 
+  = let pty = ctEvPred item
         upd_solved Nothing = Just item
         upd_solved (Just _existing_solved) = Just item 
                -- .. or Just existing_solved? Is this even possible to happen?
     in is { inert_solved = 
-               CtPredMap $ 
-               alterTM pty upd_solved (unCtPredMap $ inert_solved is) }
+               PredMap $ 
+               alterTM pty upd_solved (unPredMap $ inert_solved is) }
+
 
+updInertSet :: InertSet -> Ct -> InertSet 
+-- Add a new inert element to the inert set. 
+updInertSet is item 
   | isCNonCanonical item 
     -- NB: this may happen if we decide to kick some frozen error 
     -- out to rewrite him. Frozen errors are just NonCanonicals
@@ -548,7 +580,7 @@ updInertSet is item
     -- A canonical Given, Wanted, or Derived
   = is { inert_cans = upd_inert_cans (inert_cans is) item }
   
-  where upd_inert_cans :: InertCans -> AtomicInert -> InertCans
+  where upd_inert_cans :: InertCans -> Ct -> InertCans
         -- Precondition: item /is/ canonical
         upd_inert_cans ics item
           | isCTyEqCan item                     
@@ -578,14 +610,14 @@ updInertSet is item
                 upd_funeqs Nothing = Just item
                 upd_funeqs (Just _already_there) 
                   = panic "updInertSet: item already there!"
-            in ics { inert_funeqs = CtFamHeadMap 
+            in ics { inert_funeqs = FamHeadMap 
                                       (alterTM fam_head upd_funeqs $ 
-                                         (unCtFamHeadMap $ inert_funeqs ics)) }
+                                         (unFamHeadMap $ inert_funeqs ics)) }
           | otherwise
           = pprPanic "upd_inert set: can't happen! Inserting " $ 
             ppr item 
 
-updInertSetTcS :: AtomicInert -> TcS ()
+updInertSetTcS :: Ct -> TcS ()
 -- Add a new item in the inerts of the monad
 updInertSetTcS item
   = do { traceTcS "updInertSetTcs {" $ 
@@ -596,6 +628,32 @@ updInertSetTcS item
        ; traceTcS "updInertSetTcs }" $ empty }
 
 
+addToSolved :: CtEvidence -> TcS ()
+-- Add a new item in the solved set of the monad
+addToSolved item
+  | isIPPred (ctEvPred item)    -- Never cache "solved" implicit parameters (not sure why!)
+  = return () 
+  | otherwise
+  = do { traceTcS "updSolvedSetTcs {" $ 
+         text "Trying to insert new solved item:" <+> ppr item
+
+       ; modifyInertTcS (\is -> ((), updSolvedSet is item)) 
+                        
+       ; traceTcS "updSolvedSetTcs }" $ empty }
+
+addSolvedFunEq :: CtEvidence -> TcS ()
+addSolvedFunEq fun_eq
+  = modifyInertTcS $ \inert -> ((), upd_inert inert)
+  where 
+    upd_inert inert 
+      = let slvd = unFamHeadMap (inert_solved_funeqs inert)
+        in inert { inert_solved_funeqs =
+                      FamHeadMap (alterTM key upd_funeqs slvd) }       
+    upd_funeqs Nothing    = Just fun_eq
+    upd_funeqs (Just _ct) = Just fun_eq 
+         -- Or _ct? depends on which caches more steps of computation
+    key = ctEvPred fun_eq
+
 modifyInertTcS :: (InertSet -> (a,InertSet)) -> TcS a 
 -- Modify the inert set with the supplied function
 modifyInertTcS upd 
@@ -606,20 +664,10 @@ modifyInertTcS upd
        ; return a }
 
 
-addToSolved :: Ct -> TcS ()
--- Don't do any caching for IP preds because of delicate shadowing
-addToSolved ct
-  | isIPPred (ctPred ct)  
-  = return () 
-  | otherwise
-  = ASSERT ( isSolved (cc_flavor ct) )
-    updInertSetTcS ct
-
 extractUnsolvedTcS :: TcS (Cts,Cts) 
 -- Extracts frozen errors and remaining unsolved and sets the 
 -- inert set to be the remaining! 
-extractUnsolvedTcS = 
-  modifyInertTcS extractUnsolved 
+extractUnsolvedTcS = modifyInertTcS extractUnsolved 
 
 extractUnsolved :: InertSet -> ((Cts,Cts), InertSet)
 -- Postcondition
@@ -660,22 +708,20 @@ extractUnsolved (IS { inert_cans = IC { inert_eqs    = eqs
                               -- At some point, I used to flush all the solved, in 
                               -- fear of evidence loops. But I think we are safe, 
                               -- flushing is why T3064 had become slower
-                        , inert_solved        = solved      -- CtPredMap emptyTM
-                        , inert_flat_cache    = flat_cache  -- CtFamHeadMap emptyTM
-                        , inert_solved_funeqs = funeq_cache -- CtFamHeadMap emptyTM
+                        , inert_solved        = solved      -- PredMap emptyTM
+                        , inert_flat_cache    = flat_cache  -- FamHeadMap emptyTM
+                        , inert_solved_funeqs = funeq_cache -- FamHeadMap emptyTM
                         }
     in ((frozen, unsolved), is_solved)
 
-  where solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenOrSolvedCt ct) eqs
+  where solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenCt ct) eqs
         unsolved_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $
                        eqs `minusVarEnv` solved_eqs
 
-        (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenOrSolvedCt) irreds
+        (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenCt) irreds
         (unsolved_ips, solved_ips)       = extractUnsolvedCMap ips
         (unsolved_dicts, solved_dicts)   = extractUnsolvedCMap dicts
-
-        (unsolved_funeqs, solved_funeqs) = 
-          partCtFamHeadMap (not . isGivenOrSolved . cc_flavor) funeqs
+        (unsolved_funeqs, solved_funeqs) = partCtFamHeadMap (not . isGivenCt) funeqs
 
         unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags`
                    unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs
@@ -697,7 +743,7 @@ extractRelevantInerts wi
             in (cts, ics { inert_dicts = dict_map })
         extract_ics_relevants ct@(CFunEqCan {}) ics = 
             let (cts,feqs_map)  = 
-                  let funeq_map = unCtFamHeadMap $ inert_funeqs ics
+                  let funeq_map = unFamHeadMap $ inert_funeqs ics
                       fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct)
                       lkp = lookupTM fam_head funeq_map
                       new_funeq_map = alterTM fam_head xtm funeq_map
@@ -706,7 +752,7 @@ extractRelevantInerts wi
                   in case lkp of 
                     Nothing -> (emptyCts, funeq_map)
                     Just ct -> (singleCt ct, new_funeq_map)
-            in (cts, ics { inert_funeqs = CtFamHeadMap feqs_map })
+            in (cts, ics { inert_funeqs = FamHeadMap feqs_map })
         extract_ics_relevants (CIPCan { cc_ip_nm = nm } ) ics = 
             let (cts, ips_map) = getRelevantCts nm (inert_ips ics) 
             in (cts, ics { inert_ips = ips_map })
@@ -716,36 +762,40 @@ extractRelevantInerts wi
         extract_ics_relevants _ ics = (emptyCts,ics)
         
 
-lookupInInerts :: InertSet -> TcPredType -> Maybe Ct
+lookupInInerts :: InertSet -> TcPredType -> Maybe CtEvidence
 -- Is this exact predicate type cached in the solved or canonicals of the InertSet
 lookupInInerts (IS { inert_solved = solved, inert_cans = ics }) pty
   = case lookupInSolved solved pty of
-      Just ct -> return ct
-      Nothing -> lookupInInertCans ics pty
+      Just ctev -> return ctev
+      Nothing   -> lookupInInertCans ics pty
 
-lookupInSolved :: CtPredMap -> TcPredType -> Maybe Ct
+lookupInSolved :: PredMap CtEvidence -> TcPredType -> Maybe CtEvidence
 -- Returns just if exactly this predicate type exists in the solved.
-lookupInSolved tm pty = lookupTM pty $ unCtPredMap tm
+lookupInSolved tm pty = lookupTM pty $ unPredMap tm
 
-lookupInInertCans :: InertCans -> TcPredType -> Maybe Ct
+lookupInInertCans :: InertCans -> TcPredType -> Maybe CtEvidence
 -- Returns Just if exactly this pred type exists in the inert canonicals
 lookupInInertCans ics pty
-  = lkp_ics (classifyPredType pty)
-  where lkp_ics (ClassPred cls _)
-          = lookupCCanMap cls (\ct -> ctPred ct `eqType` pty) (inert_dicts ics)
-        lkp_ics (EqPred ty1 _ty2)
-          | Just tv <- getTyVar_maybe ty1
-          , Just ct <- lookupVarEnv (inert_eqs ics) tv
-          , ctPred ct `eqType` pty
-          = Just ct
-        lkp_ics (EqPred ty1 _ty2) -- Family equation
-          | Just _ <- splitTyConApp_maybe ty1
-          , Just ct <- lookupTM ty1 (unCtFamHeadMap $ inert_funeqs ics)
-          , ctPred ct `eqType` pty
-          = Just ct
-        lkp_ics (IrredPred {}) 
-          = find (\ct -> ctPred ct `eqType` pty) (bagToList (inert_irreds ics))
-        lkp_ics _ = Nothing -- NB: No caching for IPs
+  = case (classifyPredType pty) of
+      ClassPred cls _ 
+         -> lookupCCanMap cls (\ct -> ctEvPred ct `eqType` pty) (inert_dicts ics)
+
+      EqPred ty1 _ty2 
+         | Just tv <- getTyVar_maybe ty1      -- Tyvar equation
+         , Just ct <- lookupVarEnv (inert_eqs ics) tv
+      	 , let ctev = ctEvidence ct
+      	 , ctEvPred ctev `eqType` pty
+      	 -> Just ctev
+
+      	 | Just _ <- splitTyConApp_maybe ty1  -- Family equation
+      	 , Just ct <- lookupTM ty1 (unFamHeadMap $ inert_funeqs ics)
+      	 , let ctev = ctEvidence ct
+      	 , ctEvPred ctev `eqType` pty
+      	 -> Just ctev
+
+      IrredPred {} -> findEvidence (\ct -> ctEvPred ct `eqType` pty) (inert_irreds ics)
+    
+      _other -> Nothing -- NB: No caching for IPs
 \end{code}
 
 
@@ -1038,13 +1088,13 @@ emitTcSImplication :: Implication -> TcS ()
 emitTcSImplication imp = updTcSImplics (consBag imp)
 
 
-emitFrozenError :: CtFlavor -> SubGoalDepth -> TcS ()
+emitFrozenError :: CtEvidence -> SubGoalDepth -> TcS ()
 -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. 
 emitFrozenError fl depth 
-  = do { traceTcS "Emit frozen error" (ppr (ctFlavPred fl))
+  = do { traceTcS "Emit frozen error" (ppr (ctEvPred fl))
        ; inert_ref <- getTcSInertsRef 
        ; inerts <- wrapTcS (TcM.readTcRef inert_ref)
-       ; let ct = CNonCanonical { cc_flavor = fl
+       ; let ct = CNonCanonical { cc_ev = fl
                                 , cc_depth = depth } 
              inerts_new = inerts { inert_frozen = extendCts (inert_frozen inerts) ct } 
        ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) }
@@ -1059,24 +1109,23 @@ getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds) 
 
 getFlatCache :: TcS CtTypeMap 
-getFlatCache = getTcSInerts >>= (return . unCtFamHeadMap . inert_flat_cache)
+getFlatCache = getTcSInerts >>= (return . unFamHeadMap . inert_flat_cache)
 
 updFlatCache :: Ct -> TcS ()
 -- Pre: constraint is a flat family equation (equal to a flatten skolem)
-updFlatCache flat_eq@(CFunEqCan { cc_flavor = fl, cc_fun = tc, cc_tyargs = xis })
+updFlatCache flat_eq@(CFunEqCan { cc_ev = fl, cc_fun = tc, cc_tyargs = xis })
   = modifyInertTcS upd_inert_cache
-  where upd_inert_cache is = ((), is { inert_flat_cache = CtFamHeadMap new_fc })
+  where upd_inert_cache is = ((), is { inert_flat_cache = FamHeadMap new_fc })
                            where new_fc = alterTM pred_key upd_cache fc
-                                 fc = unCtFamHeadMap $ inert_flat_cache is
+                                 fc = unFamHeadMap $ inert_flat_cache is
         pred_key = mkTyConApp tc xis
-        upd_cache (Just ct) | cc_flavor ct `canSolve` fl = Just ct 
+        upd_cache (Just ct) | cc_ev ct `canSolve` fl = Just ct 
         upd_cache (Just _ct) = Just flat_eq 
         upd_cache Nothing    = Just flat_eq
 updFlatCache other_ct = pprPanic "updFlatCache: non-family constraint" $
                         ppr other_ct
                         
 
-
 getUntouchables :: TcS TcsUntouchables
 getUntouchables = TcS (return . tcs_untch)
 
@@ -1296,142 +1345,193 @@ instFlexiTcSHelper tvname tvkind
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 data XEvTerm = 
-  XEvTerm { ev_comp   :: [EvVar] -> EvTerm
+  XEvTerm { ev_comp   :: [EvTerm] -> EvTerm
                          -- How to compose evidence 
-          , ev_decomp :: EvVar -> [EvTerm]
+          , ev_decomp :: EvTerm -> [EvTerm]
                          -- How to decompose evidence 
           }
 
-data MaybeNew a = Fresh  { mn_thing :: a } 
-                | Cached { mn_thing :: a }
+data MaybeNew = Fresh CtEvidence | Cached EvTerm
 
-isFresh :: MaybeNew a -> Bool
+isFresh :: MaybeNew -> Bool
 isFresh (Fresh {}) = True
 isFresh _ = False
 
+getEvTerm :: MaybeNew -> EvTerm
+getEvTerm (Fresh ctev) = ctEvTerm ctev
+getEvTerm (Cached tm)  = tm
+
+getEvTerms :: [MaybeNew] -> [EvTerm]
+getEvTerms = map getEvTerm
+
+freshGoals :: [MaybeNew] -> [CtEvidence]
+freshGoals mns = [ ctev | Fresh ctev <- mns ]
+
 setEvBind :: EvVar -> EvTerm -> TcS ()
-setEvBind ev t
+setEvBind the_ev t
   = do { tc_evbinds <- getTcEvBinds
-       ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t
+       ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev t
 
-       ; traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr ev
+       ; traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev
                                      , text "t  =" <+> ppr t ]
 
 #ifndef DEBUG
        ; return () }
 #else
        ; binds <- getTcEvBindsMap
-       ; let cycle = any (reaches binds) (evVarsOfTerm t)
+       ; let cycle = reaches_tm binds t
        ; when cycle (fail_if_co_loop binds) }
 
   where fail_if_co_loop binds
-          = do { traceTcS "Cycle in evidence binds" $ vcat [ text "evvar =" <+> ppr ev
+          = do { traceTcS "Cycle in evidence binds" $ vcat [ text "evvar =" <+> ppr the_ev
                                                            , ppr (evBindMapBinds binds) ]
-               ; when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) }
+               ; when (isEqVar the_ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) }
+
+        reaches_tm :: EvBindMap -> EvTerm -> Bool
+        -- Does any free variable of 'tm' reach 'the_ev'
+        reaches_tm ebm tm = foldVarSet ((||) . reaches ebm) False (evVarsOfTerm tm)
 
         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 (evVarsOfTerm evtrm)
-                  | otherwise = False
+        -- Does this evvar reach the_ev? 
+        reaches ebm ev 
+          | ev == the_ev                                 = True
+          | Just (EvBind _ evtrm) <- lookupEvBind ebm ev = reaches_tm ebm evtrm
+          | otherwise                                    = False
 #endif
 
-newGivenEvVar  :: TcPredType -> EvTerm -> TcS (MaybeNew EvVar)
-newGivenEvVar pty evterm
-  = do { is <- getTcSInerts
-       ; case lookupInInerts is pty of
-            Just ct | isGivenOrSolvedCt ct 
-                    -> return (Cached (ctId ct))
-            _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty
-                    ; setEvBind new_ev evterm
-                    ; return (Fresh new_ev) } }
-
-newWantedEvVar :: TcPredType -> TcS (MaybeNew EvVar)
-newWantedEvVar pty
+newGivenEvVar :: GivenLoc -> TcPredType -> EvTerm -> TcS CtEvidence
+-- Make a new variable of the given PredType, 
+-- immediately bind it to the given term
+-- and return its CtEvidence
+newGivenEvVar gloc pred rhs
+  = do { new_ev <- wrapTcS $ TcM.newEvVar pred
+       ; setEvBind new_ev rhs
+       ; return (Given { ctev_gloc = gloc, ctev_pred = pred, ctev_evtm = EvId new_ev }) }
+
+newWantedEvVar :: WantedLoc -> TcPredType -> TcS MaybeNew
+newWantedEvVar loc pty
   = do { is <- getTcSInerts
        ; case lookupInInerts is pty of
-            Just ct | not (isDerivedCt ct) 
-                    -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ct
-                          ; return (Cached (ctId ct)) }
+            Just ctev | not (isDerived ctev) 
+                      -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
+                            ; return (Cached (ctEvTerm ctev)) }
             _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty
                     ; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev
-                    ; return (Fresh new_ev) } }
-
-newDerived :: TcPredType -> TcS (MaybeNew TcPredType)
-newDerived pty
+                    ; let ctev = Wanted { ctev_wloc = loc
+                                        , ctev_pred = pty
+                                        , ctev_evar = new_ev }
+                    ; return (Fresh ctev) } }
+
+newDerived :: WantedLoc -> TcPredType -> TcS (Maybe CtEvidence)
+-- Returns Nothing    if cached, 
+--         Just pred  if not cached
+newDerived loc pty
   = do { is <- getTcSInerts
        ; case lookupInInerts is pty of
-            Just {} -> return (Cached pty)
-            _       -> return (Fresh pty) }
+            Just {} -> return Nothing
+            _       -> return (Just Derived { ctev_wloc = loc
+                                            , ctev_pred = pty }) }
     
-newKindConstraint :: TcTyVar -> Kind -> TcS (MaybeNew EvVar)
+newKindConstraint :: WantedLoc -> TcTyVar -> Kind -> TcS MaybeNew
 -- Create new wanted CoVar that constrains the type to have the specified kind. 
-newKindConstraint tv knd
+newKindConstraint loc tv knd
   = do { ty_k <- wrapTcS (instFlexiTcSHelper (tyVarName tv) knd)
-       ; newWantedEvVar (mkTcEqPred (mkTyVarTy tv) ty_k) }
-
-instDFunConstraints :: TcThetaType -> TcS [MaybeNew EvVar]
-instDFunConstraints = mapM newWantedEvVar
+       ; newWantedEvVar loc (mkTcEqPred (mkTyVarTy tv) ty_k) }
 
+instDFunConstraints :: WantedLoc -> TcThetaType -> TcS [MaybeNew]
+instDFunConstraints wl = mapM (newWantedEvVar wl)
+\end{code}
                 
-xCtFlavor :: CtFlavor              -- Original flavor   
+
+Note [xCFlavor]
+~~~~~~~~~~~~~~~
+A call might look like this:
+
+    xCtFlavor ev subgoal-preds evidence-transformer
+
+  ev is Given   => use ev_decomp to create new Givens for subgoal-preds, 
+                   and return them
+
+  ev is Wanted  => create new wanteds for subgoal-preds, 
+                   use ev_comp to bind ev, 
+                   return fresh wanteds (ie ones not cached in inert_cans or solved)
+
+  ev is Derived => create new deriveds for subgoal-preds 
+                      (unless cached in inert_cans or solved)
+
+Note: The [CtEvidence] returned is a subset of the subgoal-preds passed in
+      Ones that are already cached are not returned
+
+Example
+    ev : Tree a b ~ Tree c d
+    xCtFlavor ev [a~c, b~d] (XEvTerm { ev_comp = \[c1 c2]. <Tree> c1 c2
+                                     , ev_decomp = \c. [nth 1 c, nth 2 c] })
+              (\fresh-goals.  stuff)
+
+\begin{code}
+xCtFlavor :: CtEvidence              -- Original flavor   
           -> [TcPredType]          -- New predicate types
           -> XEvTerm               -- Instructions about how to manipulate evidence
-          -> ([CtFlavor] -> TcS a) -- What to do with any remaining /fresh/ goals!
-          -> TcS a
+          -> TcS [CtEvidence]
 xCtFlavor = xCtFlavor_cache True          
 
-
 xCtFlavor_cache :: Bool            -- True = if wanted add to the solved bag!    
-          -> CtFlavor              -- Original flavor   
+          -> CtEvidence            -- Original flavor   
           -> [TcPredType]          -- New predicate types
           -> XEvTerm               -- Instructions about how to manipulate evidence
-          -> ([CtFlavor] -> TcS a) -- What to do with any remaining /fresh/ goals!
-          -> TcS a
-xCtFlavor_cache _ (Given { flav_gloc = gl, flav_evar = evar }) ptys xev cont_with
-  = do { let ev_trms = ev_decomp xev evar
-       ; new_evars <- zipWithM newGivenEvVar ptys ev_trms
-       ; cont_with $
-         map (\x -> Given gl (mn_thing x)) (filter isFresh new_evars) }
+          -> TcS [CtEvidence]
+
+xCtFlavor_cache _ (Given { ctev_gloc = gl, ctev_evtm = tm }) ptys xev
+  = ASSERT( equalLength ptys (ev_decomp xev tm) )
+    zipWithM (newGivenEvVar gl) ptys (ev_decomp xev tm)
+    -- For Givens we make new EvVars and bind them immediately. We don't worry
+    -- about caching, but we don't expect complicated calculations among Givens.
+    -- It is important to bind each given:
+    --       class (a~b) => C a b where ....
+    --       f :: C a b => ....
+    -- Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b.
+    -- But that superclass selector can't (yet) appear in a coercion
+    -- (see evTermCoercion), so the easy thing is to bind it to an Id
   
-xCtFlavor_cache cache (Wanted { flav_wloc = wl, flav_evar = evar }) ptys xev cont_with
-  = do { new_evars <- mapM newWantedEvVar ptys
-       ; let evars  = map mn_thing new_evars
-             evterm = ev_comp xev evars
-       ; setEvBind evar evterm
-       ; let solved_flav = Solved { flav_gloc = mkSolvedLoc wl UnkSkol
-                                  , flav_evar = evar }
-       ; when cache $ addToSolved (mkNonCanonical solved_flav)
-       ; cont_with $
-         map (\x -> Wanted wl (mn_thing x)) (filter isFresh new_evars) }
-    
-xCtFlavor_cache _ (Derived { flav_wloc = wl }) ptys _xev cont_with
-  = do { ders <- mapM newDerived ptys
-       ; cont_with $ 
-         map (\x -> Derived wl (mn_thing x)) (filter isFresh ders) }
+xCtFlavor_cache cache ctev@(Wanted { ctev_wloc = wl, ctev_evar = evar }) ptys xev
+  = do { new_evars <- mapM (newWantedEvVar wl) ptys
+       ; setEvBind evar (ev_comp xev (getEvTerms new_evars))
+
+           -- Add the now-solved wanted constraint to the cache
+       ; when cache $ addToSolved ctev
+
+       ; return (freshGoals new_evars) }
     
-    -- I am not sure I actually want to do this (e.g. from recanonicalizing a solved?)
-    -- but if we plan to use xCtFlavor for rewriting as well then I might as well add a case
-xCtFlavor_cache _ (Solved { flav_gloc = gl, flav_evar = evar }) ptys xev cont_with
-  = do { let ev_trms = ev_decomp xev evar
-       ; new_evars <- zipWithM newGivenEvVar ptys ev_trms
-       ; cont_with $
-         map (\x -> Solved gl (mn_thing x)) (filter isFresh new_evars) }
-
-rewriteCtFlavor :: CtFlavor
+xCtFlavor_cache _ (Derived { ctev_wloc = wl }) ptys _xev
+  = do { ders <- mapM (newDerived wl) ptys
+       ; return (catMaybes ders) }
+
+-----------------------------
+rewriteCtFlavor :: CtEvidence
                 -> TcPredType   -- new predicate
                 -> TcCoercion   -- new ~ old     
-                -> TcS (Maybe CtFlavor)
---      rewriteCtFlavor old_fl new_pred co
--- Main purpose: create a new identity (flavor) for new_pred;
---               unless new_pred is cached already
--- * Returns a new_fl : new_pred, with same wanted/given/derived flag as old_fl
--- * If old_fl was wanted, create a binding for old_fl, in terms of new_fl
--- * If old_fl was given, AND not cached, create a binding for new_fl, in terms of old_fl
--- * Returns Nothing if new_fl is already cached
+                -> TcS (Maybe CtEvidence)
+{- 
+     rewriteCtFlavor old_fl new_pred co
+Main purpose: create a new identity (flavor) for new_pred;
+              unless new_pred is cached already
+* Returns a new_fl : new_pred, with same wanted/given/derived flag as old_fl
+* If old_fl was wanted, create a binding for old_fl, in terms of new_fl
+* If old_fl was given, AND not cached, create a binding for new_fl, in terms of old_fl
+* Returns Nothing if new_fl is already cached
+
+
+        Old evidence    New predicate is               Return new evidence
+        flavour                                        of same flavor
+        -------------------------------------------------------------------
+        Wanted          Already solved or in inert     Nothing
+        or Derived      Not                            Just new_evidence
+
+        Given           Already in inert               Nothing
+                        Not                            Just new_evidence
+
+        Solved          NEVER HAPPENS
+-}
 
 rewriteCtFlavor = rewriteCtFlavor_cache True
 -- Returns Just new_fl iff either (i)  'co' is reflexivity
@@ -1439,40 +1539,40 @@ rewriteCtFlavor = rewriteCtFlavor_cache True
 -- In either case, there is nothing new to do with new_fl
 
 rewriteCtFlavor_cache :: Bool 
-                -> CtFlavor
+                -> CtEvidence
                 -> TcPredType   -- new predicate
                 -> TcCoercion   -- new ~ old     
-                -> TcS (Maybe CtFlavor)
+                -> TcS (Maybe CtEvidence)
 -- If derived, don't even look at the coercion
 -- NB: this allows us to sneak away with ``error'' thunks for 
 -- coercions that come from derived ids (which don't exist!) 
-rewriteCtFlavor_cache _cache (Derived wl _pty_orig) pty_new _co
-  = newDerived pty_new >>= from_mn
-  where from_mn (Cached {}) = return Nothing
-        from_mn (Fresh {})  = return $ Just (Derived wl pty_new)
+rewriteCtFlavor_cache _cache (Derived { ctev_wloc = wl }) pty_new _co
+  = newDerived wl pty_new
         
-rewriteCtFlavor_cache cache fl pty co
-  | isTcReflCo co
-  -- If just reflexivity then you may re-use the same variable as optimization
-  = if ctFlavPred fl `eqType` pty then 
-      -- E.g. for type synonyms we want to use the original type 
-      -- since it's not flattened to report better error messages.
-      return $ Just fl
-    else 
-      -- E.g. because we rewrite with a spontaneously solved one
-      return (Just $ case fl of
-                 Derived wl _pty_orig -> Derived wl pty
-                 Given gl ev  -> Given  gl (setVarType ev pty)
-                 Wanted wl ev -> Wanted wl (setVarType ev pty)
-                 Solved gl ev -> Solved gl (setVarType ev pty))
-  | otherwise 
-  = xCtFlavor_cache cache fl [pty] (XEvTerm ev_comp ev_decomp) cont
-  where ev_comp [x] = mkEvCast x co
-        ev_comp _   = panic "Coercion can only have one subgoal"
-        ev_decomp x = [mkEvCast x (mkTcSymCo co)]
-        cont []     = return Nothing
-        cont [fl]   = return $ Just fl
-        cont _      = panic "At most one constraint can be subgoal of coercion!"
+rewriteCtFlavor_cache _cache (Given { ctev_gloc = gl, ctev_evtm = old_tm }) pty_new co
+  = return (Just (Given { ctev_gloc = gl, ctev_pred = pty_new, ctev_evtm = new_tm }))
+  where
+    new_tm = mkEvCast old_tm (mkTcSymCo co)  -- mkEvCase optimises ReflCo
+  
+rewriteCtFlavor_cache cache ctev@(Wanted { ctev_wloc = wl, ctev_evar = evar, ctev_pred = pty_old }) pty_new co
+  | isTcReflCo co  -- If just reflexivity then you may re-use the same variable
+  = return (Just (if pty_old `eqType` pty_new 
+                  then ctev 
+                  else ctev { ctev_pred = pty_new }))
+       -- If the old and new types compare equal (eqType looks through synonyms)
+       -- then retain the old type, so that error messages come out mentioning synonyms
+
+  | otherwise
+  = do { new_evar <- newWantedEvVar wl pty_new
+       ; setEvBind evar (mkEvCast (getEvTerm new_evar) co)
+
+           -- Add the now-solved wanted constraint to the cache
+       ; when cache $ addToSolved ctev
+
+       ; case new_evar of
+            Fresh ctev -> return (Just ctev) 
+            _          -> return Nothing }
+
 
 
 -- Matching and looking up classes and family instances
@@ -1537,29 +1637,29 @@ deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2)
             phi1 = Type.substTy subst1 body1
             phi2 = Type.substTy (zipTopTvSubst tvs2 tys) body2
             skol_info = UnifyForAllSkol skol_tvs phi1
-        ; mev <- newWantedEvVar (mkTcEqPred phi1 phi2)
-        ; let new_fl = Wanted loc (mn_thing mev)
-              new_ct = mkNonCanonical new_fl
-              new_co = mkTcCoVarCo (mn_thing mev)
-        ; coe_inside <- if isFresh mev then
-                           do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds
-                              ; let ev_binds = TcEvBinds ev_binds_var
-                              ; lcl_env <- wrapTcS $ TcM.getLclTypeEnv
-                              ; loc <- wrapTcS $ TcM.getCtLoc skol_info
-                              ; let wc = WC { wc_flat  = singleCt new_ct 
-                                            , wc_impl  = emptyBag
-                                            , wc_insol = emptyCts }
-                                    imp = Implic { ic_untch  = all_untouchables
-                                                 , ic_env    = lcl_env
-                                                 , ic_skols  = skol_tvs
-                                                 , ic_given  = []
-                                                 , ic_wanted = wc 
-                                                 , ic_insol  = False
-                                                 , ic_binds  = ev_binds_var
-                                                 , ic_loc    = loc }
-                           ; updTcSImplics (consBag imp) 
-                           ; return (TcLetCo ev_binds new_co) }
-                        else (return new_co)
+        ; mev <- newWantedEvVar loc (mkTcEqPred phi1 phi2)
+        ; coe_inside <- case mev of
+            Cached ev_tm -> return (evTermCoercion ev_tm)
+            Fresh ctev   -> do { ev_binds_var <- wrapTcS $ TcM.newTcEvBinds
+                               ; let ev_binds = TcEvBinds ev_binds_var
+                                     new_ct = mkNonCanonical ctev
+              			     new_co = evTermCoercion (ctEvTerm ctev)
+                               ; lcl_env <- wrapTcS $ TcM.getLclTypeEnv
+                               ; loc <- wrapTcS $ TcM.getCtLoc skol_info
+                               ; let wc = WC { wc_flat  = singleCt new_ct 
+                                             , wc_impl  = emptyBag
+                                             , wc_insol = emptyCts }
+                                     imp = Implic { ic_untch  = all_untouchables
+                                                  , ic_env    = lcl_env
+                                                  , ic_skols  = skol_tvs
+                                                  , ic_given  = []
+                                                  , ic_wanted = wc 
+                                                  , ic_insol  = False
+                                                  , ic_binds  = ev_binds_var
+                                                  , ic_loc    = loc }
+                               ; updTcSImplics (consBag imp) 
+                               ; return (TcLetCo ev_binds new_co) }
+
         ; setEvBind orig_ev $
           EvCoercion (foldr mkTcForAllCo coe_inside skol_tvs)
         }
@@ -1573,7 +1673,6 @@ deferTcSForAllEq (loc,orig_ev) (tvs1,body1) (tvs2,body2)
 -- Rewriting with respect to the inert equalities 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 \begin{code}
-
 getInertEqs :: TcS (TyVarEnv Ct, InScopeSet)
 getInertEqs = do { inert <- getTcSInerts
                  ; let ics = inert_cans inert
@@ -1581,11 +1680,14 @@ getInertEqs = do { inert <- getTcSInerts
 
 getCtCoercion :: EvBindMap -> Ct -> TcCoercion
 -- Precondition: A CTyEqCan which is either Wanted or Given, never Derived or Solved!
-getCtCoercion bs ct 
+getCtCoercion _bs ct 
+  = ASSERT( not (isDerivedCt ct) )
+    evTermCoercion (ctEvTerm (ctEvidence ct))
+{-       ToDo: check with Dimitrios that we can dump this stuff
   = case lookupEvBind bs cc_id of
         -- Given and bound to a coercion term
       Just (EvBind _ (EvCoercion co)) -> co
-                      -- NB: The constraint could have been rewritten due to spontaneous 
+                -- NB: The constraint could have been rewritten due to spontaneous 
                 -- unifications but because we are optimizing away mkRefls the evidence
                 -- variable may still have type (alpha ~ [beta]). The constraint may 
                 -- however have a more accurate type (alpha ~ [Int]) (where beta ~ Int has
@@ -1596,6 +1698,9 @@ getCtCoercion bs ct
 
       _ -> mkTcCoVarCo (setVarType cc_id (ctPred ct))
       
-  where cc_id = ctId ct
-
+  where 
+    cc_id = ctId ct
+-}
 \end{code}
+
+
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index e6a4fd2f79..f97347a305 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -558,7 +558,7 @@ simplifyRule name lhs_wanted rhs_wanted
 		 -- variables; hence NoUntouchables
 
        ; (resid_wanted, _) <- runTcS (SimplInfer doc) untch emptyInert emptyWorkList $
-              solveWanteds zonked_all
+                              solveWanteds zonked_all
 
        ; zonked_lhs <- zonkWC lhs_wanted
 
@@ -579,7 +579,8 @@ simplifyRule name lhs_wanted rhs_wanted
          vcat [ text "zonked_lhs" <+> ppr zonked_lhs 
               , text "q_cts"      <+> ppr q_cts ]
 
-       ; return (map ctId (bagToList q_cts), zonked_lhs { wc_flat = non_q_cts }) }
+       ; return ( map (ctEvId . ctEvidence) (bagToList q_cts)
+                , zonked_lhs { wc_flat = non_q_cts }) }
 \end{code}
 
 
@@ -784,10 +785,11 @@ solveNestedImplications implics
   where givens_from_wanteds = foldrBag get_wanted []
         get_wanted cc rest_givens
             | pushable_wanted cc
-            = let fl = cc_flavor cc
-                  wloc = flav_wloc fl
-                  gfl = Given (mkGivenLoc wloc UnkSkol) (flav_evar fl) 
-                  this_given = cc { cc_flavor = gfl }
+            = let fl   = ctEvidence cc
+                  gfl  = Given { ctev_gloc = setCtLocOrigin (ctev_wloc fl) UnkSkol
+                               , ctev_evtm = EvId (ctev_evar fl)
+                               , ctev_pred = ctev_pred fl }
+                  this_given = cc { cc_ev = gfl }
               in this_given : rest_givens
             | otherwise = rest_givens 
 
@@ -1025,20 +1027,20 @@ solveCTyFunEqs cts
 
       ; return (niFixTvSubst ni_subst, unsolved_can_cts) }
   where
-    solve_one (Wanted _ cv,tv,ty) 
+    solve_one (Wanted { ctev_evar = cv }, tv, ty) 
       = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty))
     solve_one (Derived {}, tv, ty)
       = setWantedTyBind tv ty
     solve_one arg
       = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg
 ------------
-type FunEqBinds = (TvSubstEnv, [(CtFlavor, TcTyVar, TcType)])
+type FunEqBinds = (TvSubstEnv, [(CtEvidence, TcTyVar, TcType)])
   -- The TvSubstEnv is not idempotent, but is loop-free
   -- See Note [Non-idempotent substitution] in Unify
 emptyFunEqBinds :: FunEqBinds
 emptyFunEqBinds = (emptyVarEnv, [])
 
-extendFunEqBinds :: FunEqBinds -> CtFlavor -> TcTyVar -> TcType -> FunEqBinds
+extendFunEqBinds :: FunEqBinds -> CtEvidence -> TcTyVar -> TcType -> FunEqBinds
 extendFunEqBinds (tv_subst, cv_binds) fl tv ty
   = (extendVarEnv tv_subst tv ty, (fl, tv, ty):cv_binds)
 
@@ -1052,7 +1054,7 @@ getSolvableCTyFunEqs untch cts
     dflt_funeq :: (Cts, FunEqBinds) -> Ct
                -> (Cts, FunEqBinds)
     dflt_funeq (cts_in, feb@(tv_subst, _))
-               (CFunEqCan { cc_flavor = fl
+               (CFunEqCan { cc_ev = fl
                           , cc_fun = tc
                           , cc_tyargs = xis
                           , cc_rhs = xi })
@@ -1071,7 +1073,7 @@ getSolvableCTyFunEqs untch cts
 
       , not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis))
            -- Occurs check: see Note [Solving Family Equations], Point 2
-      = ASSERT ( not (isGivenOrSolved fl) )
+      = ASSERT ( not (isGiven fl) )
         (cts_in, extendFunEqBinds feb fl tv (mkTyConApp tc xis))
 
     dflt_funeq (cts_in, fun_eq_binds) ct
@@ -1210,16 +1212,16 @@ defaultTyVar untch the_tv
   , not (k `eqKind` default_k)
   = tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting]
     do { let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk
-       ; eqv <- TcSMonad.newKindConstraint the_tv default_k
+       ; eqv <- TcSMonad.newKindConstraint loc the_tv default_k
        ; case eqv of
            Fresh x -> 
              return $ unitBag $
-             CNonCanonical { cc_flavor = Wanted loc x, cc_depth = 0 }
+             CNonCanonical { cc_ev = x, cc_depth = 0 }
            Cached _ -> return emptyBag }
 {- DELETEME
          if isNewEvVar eqv then 
              return $ unitBag (CNonCanonical { cc_id = evc_the_evvar eqv
-                                             , cc_flavor = fl, cc_depth = 0 })
+                                             , cc_ev = fl, cc_depth = 0 })
          else return emptyBag }
 -}
 
@@ -1300,13 +1302,12 @@ disambigGroup (default_ty:default_tys) group
        ; success <- tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting]
                     do { derived_eq <- tryTcS $
                                        -- I need a new tryTcS because we will call solveInteractCts below!
-                            do { md <- newDerived (mkTcEqPred (mkTyVarTy the_tv) default_ty)
+                            do { md <- newDerived (ctev_wloc the_fl) 
+                                                  (mkTcEqPred (mkTyVarTy the_tv) default_ty)
+                                                  -- ctev_wloc because constraint is not Given!
                                ; case md of 
-                                    Cached _ -> return []
-                                    Fresh pty -> 
-                                      -- flav_wloc because constraint is not Given/Solved!
-                                      let dfl = Derived (flav_wloc the_fl) pty
-                                      in return [ CNonCanonical { cc_flavor = dfl, cc_depth = 0 } ] }
+                                    Nothing   -> return []
+                                    Just ctev -> return [ mkNonCanonical ctev ] }
                             
                        ; traceTcS "disambigGroup (solving) {" 
                                   (text "trying to solve constraints along with default equations ...")
@@ -1335,7 +1336,7 @@ disambigGroup (default_ty:default_tys) group
                        ; disambigGroup default_tys group } }
   where
     ((the_ct,the_tv):_) = group
-    the_fl              = cc_flavor the_ct
+    the_fl              = cc_ev the_ct
     wanteds             = map fst group
 \end{code}
 
@@ -1365,9 +1366,12 @@ newFlatWanteds :: CtOrigin -> ThetaType -> TcM [Ct]
 newFlatWanteds orig theta
   = do { loc <- getCtLoc orig
        ; mapM (inst_to_wanted loc) theta }
-  where inst_to_wanted loc pty 
+  where 
+    inst_to_wanted loc pty 
           = do { v <- TcMType.newWantedEvVar pty 
                ; return $ 
-                 CNonCanonical { cc_flavor = Wanted loc v
+                 CNonCanonical { cc_ev = Wanted { ctev_evar = v
+                                                , ctev_wloc = loc
+                                                , ctev_pred = pty }
                                , cc_depth = 0 } }
 \end{code}
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 6e4d12852e..c44ce31f2e 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -31,7 +31,6 @@ module TcUnify (
   matchExpectedFunTys,
   matchExpectedFunKind,
   wrapFunResCoercion,
-  wrapEqCtxt,
 
   --------------------------------
   -- Errors
@@ -43,7 +42,6 @@ module TcUnify (
 
 import HsSyn
 import TypeRep
-import TcErrors	( unifyCtxt )
 import TcMType
 import TcIface
 import TcRnMonad
@@ -535,7 +533,9 @@ uType_defer items ty1 ty2
   = ASSERT( not (null items) )
     do { eqv <- newEq ty1 ty2
        ; loc <- getCtLoc (TypeEqOrigin (last items))
-       ; emitFlat $ mkNonCanonical (Wanted loc eqv)
+       ; let ctev = Wanted { ctev_wloc = loc, ctev_evar = eqv
+                           , ctev_pred = mkTcEqPred ty1 ty2 }
+       ; emitFlat $ mkNonCanonical ctev 
 
        -- Error trace only
        -- NB. do *not* call mkErrInfo unless tracing is on, because
@@ -1005,15 +1005,6 @@ we return a made-up TcTyVarDetails, but I think it works smoothly.
 pushOrigin :: TcType -> TcType -> [EqOrigin] -> [EqOrigin]
 pushOrigin ty_act ty_exp origin
   = UnifyOrigin { uo_actual = ty_act, uo_expected = ty_exp } : origin
-
----------------
-wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a
--- Build a suitable error context from the origin and do the thing inside
--- The "couldn't match" error comes from the innermost item on the stack,
--- and, if there is more than one item, the "Expected/inferred" part
--- comes from the outermost item
-wrapEqCtxt []    thing_inside = thing_inside
-wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside
 \end{code}
 
 
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 1360baca6b..42e54ba47b 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -30,7 +30,7 @@ module Coercion (
 	-- ** Constructing coercions
         mkReflCo, mkCoVarCo, 
         mkAxInstCo, mkAxInstRHS,
-        mkPiCo, mkPiCos,
+        mkPiCo, mkPiCos, mkCoCast,
         mkSymCo, mkTransCo, mkNthCo,
 	mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo,
         mkForAllCo, mkUnsafeCo,
@@ -672,6 +672,18 @@ mkPiCos vs co = foldr mkPiCo co vs
 mkPiCo  :: Var -> Coercion -> Coercion
 mkPiCo v co | isTyVar v = mkForAllCo v co
             | otherwise = mkFunCo (mkReflCo (varType v)) co
+
+mkCoCast :: Coercion -> Coercion -> Coercion
+-- (mkCoCast (c :: s1 ~# t1) (g :: (s1 ~# t1) ~# (s2 ~# t2)
+mkCoCast c g
+  = mkSymCo g1 `mkTransCo` c `mkTransCo` g2
+  where
+       -- g  :: (s1 ~# s2) ~# (t1 ~#  t2)
+       -- g1 :: s1 ~# t1
+       -- g2 :: s2 ~# t2
+    [_reflk, g1, g2] = decomposeCo 3 g
+            -- Remember, (~#) :: forall k. k -> k -> *
+            -- so it takes *three* arguments, not two
 \end{code}
 
 %************************************************************************
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index a0a69c63e4..d6a744c7ac 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -1482,9 +1482,10 @@ instance Outputable TyCon where
 
 pprPromotionQuote :: TyCon -> SDoc
 pprPromotionQuote (PromotedDataCon {}) = char '\''   -- Quote promoted DataCons in types
+pprPromotionQuote (PromotedTyCon {})   = ifPprDebug (char '\'') 
 pprPromotionQuote _                    = empty       -- However, we don't quote TyCons in kinds
                                                      -- e.g.   type family T a :: Bool -> *
-                                                     -- cf Trac #5952
+                                                     -- cf Trac #5952.  Except with -dppr-debug
 
 instance NamedThing TyCon where
     getName = tyConName
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index e0de629da6..f81aebbfcd 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -973,14 +973,17 @@ getClassPredTys_maybe ty = case splitTyConApp_maybe ty of
         _ -> Nothing
 
 getEqPredTys :: PredType -> (Type, Type)
-getEqPredTys ty = case getEqPredTys_maybe ty of
-        Just (ty1, ty2) -> (ty1, ty2)
-        Nothing         -> pprPanic "getEqPredTys" (ppr ty)
+getEqPredTys ty 
+  = case splitTyConApp_maybe ty of 
+      Just (tc, (_ : ty1 : ty2 : tys)) -> ASSERT( tc `hasKey` eqTyConKey && null tys )
+                                          (ty1, ty2)
+      _ -> pprPanic "getEqPredTys" (ppr ty)
 
 getEqPredTys_maybe :: PredType -> Maybe (Type, Type)
-getEqPredTys_maybe ty = case splitTyConApp_maybe ty of 
-        Just (tc, [_, ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2)
-        _ -> Nothing
+getEqPredTys_maybe ty 
+  = case splitTyConApp_maybe ty of 
+      Just (tc, [_, ty1, ty2]) | tc `hasKey` eqTyConKey -> Just (ty1, ty2)
+      _ -> Nothing
 
 getIPPredTy_maybe :: PredType -> Maybe (IPName Name, Type)
 getIPPredTy_maybe ty = case splitTyConApp_maybe ty of 
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 8f6e32130f..3ac9c5105f 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -361,18 +361,18 @@ vectTopRhs recFs var expr
     rhs _globalScalar _isDFun (Just (_, expr'))               -- Case (1)
       = return (inlineMe, False, expr')
     rhs True          False   Nothing                         -- Case (2)
-      = do { expr' <- vectScalarFun recFs expr
+      = do { expr' <- vectScalarFun expr
            ; return (inlineMe, True, vectorised expr')
            }
     rhs True          True    Nothing                         -- Case (3)
-      = do { expr' <- vectScalarDFun var recFs
+      = do { expr' <- vectScalarDFun var
            ; return (DontInline, True, expr')
            }
     rhs False         False   Nothing                         -- Case (4) — not a dfun
       = do { let exprFvs = freeVars expr
            ; (inline, isScalar, vexpr) 
                <- inBind var $
-                    vectPolyExpr (isStrongLoopBreaker $ idOccInfo var) recFs exprFvs
+                    vectPolyExpr (isStrongLoopBreaker $ idOccInfo var) recFs exprFvs Nothing
            ; return (inline, isScalar, vectorised vexpr)
            }
     rhs False         True    Nothing                         -- Case (4) — is a dfun
diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index 0764c3b255..e75cf0e009 100644
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -51,271 +51,120 @@ import TcRnMonad (doptM)
 import DynFlags (DynFlag(Opt_AvoidVect))
 
 
--- For prototyping, the VITree is a separate data structure with the same shape as the corresponding expression
--- tree. This will become part of the annotation
-
-data VectInfo = VIParr 
-              | VISimple
-              | VIComplex
-              | VIEncaps
-              deriving (Eq, Show)
-              
-data VITree = VITNode VectInfo [VITree] 
-          deriving (Show)
-          
-viTrace :: CoreExprWithFVs -> VectInfo -> [VITree] -> VM ()
-viTrace ce vi vTs = 
-  -- return ()
-  traceVt ("vitrace " ++ (show vi) ++ "[" ++ (concat $ map (\(VITNode vi _) -> show vi ++ " ") vTs) ++"]") (ppr $ deAnnotate ce)
-          
-viOr :: [VITree] -> Bool
-viOr = or . (map (\(VITNode vi _) -> vi == VIParr))
- 
--- TODO: free scalar vars don't actually need to be passed through, since encapsulations makes sure, that there are
---        no free variables in encapsulated lambda expressions     
-vectInfo:: CoreExprWithFVs -> VM VITree
-vectInfo ce@(_, AnnVar v) 
-  = do { vi <- vectInfoType $ exprType $ deAnnotate ce
-       ; viTrace ce vi [] 
-       ; traceVt "vectInfo AnnVar"  ((ppr v) <+> (ppr $ exprType $ deAnnotate ce))
-       ; return $ VITNode vi []
-       }
-
-vectInfo ce@(_, AnnLit _)     
-  = do { vi <- vectInfoType $ exprType $ deAnnotate ce  
-       ; viTrace ce vi [] 
-       ; traceVt "vectInfo AnnLit"  (ppr $ exprType $ deAnnotate ce)       
-       ; return $ VITNode vi []
-       }
-     
-vectInfo ce@(_, AnnApp e1 e2)  
-  = do { vt1  <- vectInfo e1  
-       ; vt2  <- vectInfo e2  
-       ; vi <- if viOr [vt1, vt2] 
-                    then return VIParr
-                    else vectInfoType $ exprType $ deAnnotate ce
-       ; viTrace ce vi [vt1, vt2]                     
-       ; return  $ VITNode vi [vt1, vt2]
-     }
-       
-vectInfo ce@(_, AnnLam _var body) 
-  = do { vt@(VITNode vi _) <- vectInfo body  
-       ; viTrace ce vi [vt]  
-       ; if (vi == VIParr)                     
-           then return $ VITNode vi [vt]
-           else return $ VITNode VIComplex [vt]
-       }
-
-vectInfo ce@(_, AnnLet (AnnNonRec _var expr) body)  
-  = do { vtE <- vectInfo expr 
-       ; vtB <- vectInfo body 
-       ; vi <- if viOr [vtE, vtB] 
-                     then return VIParr
-                     else vectInfoType $ exprType $ deAnnotate ce
-       ; viTrace ce vi [vtE, vtB]                                          
-       ; return  $ VITNode vi [vtE, vtB]
-      }
-
-vectInfo ce@(_, AnnLet (AnnRec bnds) body)  
-  = do { let (_, exprs) = unzip bnds
-       ; vtBnds <- mapM (\e -> vectInfo e) exprs
-       ; if (viOr  vtBnds)
-            then do { vtBnds' <- mapM (\e -> vectInfo e) exprs    
-                    ; vtB <- vectInfo body 
-                    ; return (VITNode VIParr (vtB: vtBnds'))
-                    }
-            else do { vtB@(VITNode vib _)  <- vectInfo body 
-                    ; ni <- if (vib == VIParr) 
-                               then return VIParr
-                               else vectInfoType $ exprType $ deAnnotate ce
-                    ; viTrace ce ni (vtB : vtBnds)                                        
-                    ; return  $ VITNode ni (vtB : vtBnds)
-                    }
-       }
-
-vectInfo ce@(_, AnnCase expr _var _ty alts) 
-  = do { vtExpr <- vectInfo expr 
-       ; vtAlts <- mapM (\(_, _, e) -> vectInfo e) alts
-       ; ni <- if viOr (vtExpr : vtAlts)
-                 then return VIParr
-                 else vectInfoType $ exprType $ deAnnotate ce
-       ; viTrace ce ni (vtExpr  : vtAlts)
-       ; return $ VITNode ni (vtExpr: vtAlts)
-       }
-        
-
-vectInfo (_, AnnCast expr _)       
-  = do { vt@(VITNode vi _) <- vectInfo expr 
-       ; return $ VITNode vi [vt]
-       }
-       
-vectInfo (_, AnnTick _ expr )       
-  = do { vt@(VITNode vi _) <- vectInfo expr 
-       ; return $ VITNode vi [vt]
-       }
-       
-vectInfo (_, AnnType {})  
-  = return $ VITNode VISimple []
-  
-vectInfo (_, AnnCoercion {}) 
-  = return $ VITNode VISimple []
-  
-  
-         
-vectInfoType:: Type -> VM VectInfo   
-vectInfoType ty 
-  | maybeParrTy ty = return VIParr
-  | otherwise      
-      = do { sType <- isSimpleType ty
-           ; if sType 
-               then return VISimple
-               else return VIComplex
-           }
-
-
--- Checks whether the type might be a parallel array type.  In particular, if the outermost
--- constructor is a type family, we conservatively assume that it may be a parallel array type.
-maybeParrTy :: Type -> Bool
-maybeParrTy ty 
-    | Just ty'         <- coreView ty            = maybeParrTy ty'
-    | Just (tyCon, ts) <- splitTyConApp_maybe ty = isPArrTyCon tyCon || isSynFamilyTyCon tyCon  
-                                                 || or (map maybeParrTy ts)
-maybeParrTy _  = False               
-  
+-- Main entry point to vectorise expressions -----------------------------------
 
-isSimpleType:: Type -> VM Bool
-isSimpleType ty 
-  | Just (c, _cs) <- splitTyConApp_maybe ty = return $ (tyConName c) `elem` [boolTyConName, intTyConName, word8TyConName, doubleTyConName, floatTyConName]
-{-
-    = do { globals <- globalScalarTyCons
-          ; traceVt ("isSimpleType " ++ (show (elemNameSet (tyConName c) globals ))) (ppr c)  
-          ; return (elemNameSet (tyConName c) globals ) 
-          } 
-  -}
-  | Nothing <- splitTyConApp_maybe ty
-    = return False
-isSimpleType ty 
-  = pprPanic "Vectorise.Exp.isSimpleType not handled" (ppr ty)
-
-varsSimple :: VarSet -> VM Bool
-varsSimple vs 
-  = do { varTypes <- mapM isSimpleType $ map varType $  varSetElems vs
-       ; return $ and varTypes
-       }
-   
-   
--- | Vectorise a polymorphic expression.
-vectPolyExpr:: Bool -> [Var]  -> CoreExprWithFVs
-            -> VM (Inline, Bool, VExpr)
-vectPolyExpr loop_breaker recFns (_, AnnTick tickish expr)
-  = do { (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr
-       ; return (inline, isScalarFn, vTick tickish expr')
-       }
-       
-
-
-vectPolyExpr loop_breaker recFns expr
-  = do { vectAvoidance <- liftDs $ doptM Opt_AvoidVect
-       ; vi <- vectInfo expr  
-       ; ((tvs, mono), vi') <- 
-          if vectAvoidance
-            then do { (extExpr, vi') <- encapsulateScalar vi expr
-                    ; traceVt "vectPolyExpr extended:"  (ppr $ deAnnotate extExpr)
-                    ; return $ (collectAnnTypeBinders extExpr , vi')
-                    }
-            else return $ (collectAnnTypeBinders expr, vi)
-       ; arity <- polyArity tvs
-       ; polyAbstract tvs $ \args ->
-           do {(inline, isScalarFn, mono') <- vectFnExpr False loop_breaker recFns mono vi'
-              ; return (addInlineArity inline arity, isScalarFn, mapVect (mkLams $ tvs ++ args) mono')
-              }
-       }
-
--- todo: clean this     
-  
-vectPolyExprVT:: Bool -> [Var]  -> CoreExprWithFVs -> VITree
-            -> VM (Inline, Bool, VExpr)
-
--- vectPolyExprVT  _loop_breaker _recFns e vi | not (checkTree vi (deAnnotate e))
---  = pprPanic "vectPolyExprVT" (ppr $ deAnnotate e)
-vectPolyExprVT  loop_breaker recFns (_, AnnTick tickish expr) (VITNode _ [vit]) 
-  = do { (inline, isScalarFn, expr') <- vectPolyExprVT loop_breaker recFns expr vit
-       ; return (inline, isScalarFn, vTick tickish expr')
-       }
-       
-vectPolyExprVT loop_breaker recFns expr vi
-  = do { -- checkTreeAnnM vi expr ;      
-         let (tvs, mono) = collectAnnTypeBinders expr
-       ; arity <- polyArity tvs
-       ; polyAbstract tvs $ \args ->
-           do { (inline, isScalarFn, mono') <- vectFnExpr False loop_breaker recFns mono vi
-              ; return (addInlineArity inline arity, isScalarFn, mapVect (mkLams $ tvs ++ args) mono')
-              }
-       }
+-- |Vectorise a polymorphic expression.
+--
+-- If not yet available, precompute vectorisation avoidance information before vectorising.  If
+-- the vectorisation avoidance optimisation is enabled, also use the vectorisation avoidance
+-- information to encapsulated subexpression that do not need to be vectorised.
+--
+vectPolyExpr :: Bool -> [Var] -> CoreExprWithFVs -> Maybe VITree
+             -> VM (Inline, Bool, VExpr)
+  -- precompute vectorisation avoidance information (and possibly encapsulated subexpressions)
+vectPolyExpr loop_breaker recFns expr Nothing
+  = do
+    { vectAvoidance <- liftDs $ doptM Opt_AvoidVect
+    ; vi <- vectAvoidInfo expr  
+    ; (expr', vi') <- 
+        if vectAvoidance
+        then do 
+             { (expr', vi') <- encapsulateScalars vi expr
+             ; traceVt "vectPolyExpr encapsulated:" (ppr $ deAnnotate expr')
+             ; return (expr', vi')
+             }
+        else return (expr, vi)
+    ; vectPolyExpr loop_breaker recFns expr' (Just vi')
+    }
+
+  -- traverse through ticks
+vectPolyExpr loop_breaker recFns (_, AnnTick tickish expr) (Just (VITNode _ [vit])) 
+  = do 
+    { (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr (Just vit)
+    ; return (inline, isScalarFn, vTick tickish expr')
+    }
+
+  -- collect and vectorise type abstractions; then, descent into the body
+vectPolyExpr loop_breaker recFns expr (Just vit)
+  = do 
+    { let (tvs, mono) = collectAnnTypeBinders expr
+          vit'        = stripLevels (length tvs) vit
+    ; arity <- polyArity tvs
+    ; polyAbstract tvs $ \args ->
+        do 
+        { (inline, isScalarFn, mono') <- vectFnExpr False loop_breaker recFns mono vit'
+        ; return (addInlineArity inline arity, isScalarFn, mapVect (mkLams $ tvs ++ args) mono')
+        }
+    }
+  where
+    stripLevels 0 vit               = vit
+    stripLevels n (VITNode _ [vit]) = stripLevels (n - 1) vit
+    stripLevels _ vit               = pprPanic "vectPolyExpr: stripLevels:" (text (show vit))
 
--- | encapsulate every purely sequential subexpression with a simple return type 
---   of a (potentially) parallel expression into a lambda abstraction over all its
---   free variables followed by the corresponding application to those variables.
---   Condition:
---      all free variables and the result type must be of `simple' type 
---      the expression is 'complex enough', which is, for now, every expression
---      which is not constant and contains at least one operation.
+-- Encapsulate every purely sequential subexpression of a (potentially) parallel expression into a
+-- into a lambda abstraction over all its free variables followed by the corresponding application
+-- to those variables.  We can, then, avoid the vectorisation of the ensapsulated subexpressions.
+--
+-- Preconditions:
+--
+-- * All free variables and the result type must be /simple/ types.
+-- * The expression is sufficientlt complex (top warrant special treatment).  For now, that is
+--   every expression that is not constant and contains at least one operation.
 --  
-encapsulateScalar :: VITree -> CoreExprWithFVs -> VM (CoreExprWithFVs, VITree)
-encapsulateScalar  vit ce@(_, AnnType _ty) 
+encapsulateScalars :: VITree -> CoreExprWithFVs -> VM (CoreExprWithFVs, VITree)
+encapsulateScalars  vit ce@(_, AnnType _ty) 
   = return (ce, vit)
       
-encapsulateScalar  vit ce@(_, AnnVar _v)  
+encapsulateScalars  vit ce@(_, AnnVar _v)  
   = return (ce, vit)
   
-encapsulateScalar vit ce@(_, AnnLit _)
+encapsulateScalars vit ce@(_, AnnLit _)
   = return (ce, vit) 
 
-         
-encapsulateScalar (VITNode vi [vit]) (fvs, AnnTick tck expr)
-  = do { (extExpr, vit') <- encapsulateScalar  vit expr
+encapsulateScalars (VITNode vi [vit]) (fvs, AnnTick tck expr)
+  = do { (extExpr, vit') <- encapsulateScalars vit expr
        ; return ((fvs, AnnTick tck extExpr), VITNode vi [vit'])
        }
 
-encapsulateScalar _ (_fvs, AnnTick _tck _expr)
+encapsulateScalars _ (_fvs, AnnTick _tck _expr)
   = panic "encapsulateScalar AnnTick doesn't match up"
   
-encapsulateScalar (VITNode vi [vit]) ce@(fvs, AnnLam bndr expr) 
+encapsulateScalars (VITNode vi [vit]) ce@(fvs, AnnLam bndr expr) 
   = do { varsS <- varsSimple fvs 
        ; case (vi, varsS) of
-           (VISimple, True) -> do { let (e', vit') = encaps vit ce
+           (VISimple, True) -> do { let (e', vit') = liftSimple vit ce
                                   ; return (e', vit') 
                                   }
-           _                -> do { (extExpr, vit')  <- encapsulateScalar vit expr
+           _                -> do { (extExpr, vit') <- encapsulateScalars vit expr
                                   ; return ((fvs, AnnLam bndr extExpr), VITNode vi [vit'])
                                   }
        }
 
-encapsulateScalar _ (_fvs, AnnLam _bndr _expr) 
-  = panic "encapsulateScalar AnnLam doesn't match up"
+encapsulateScalars _ (_fvs, AnnLam _bndr _expr) 
+  = panic "encapsulateScalars AnnLam doesn't match up"
 
-
-encapsulateScalar vt@(VITNode vi [vit1, vit2]) ce@(fvs, AnnApp ce1 ce2) 
+encapsulateScalars vt@(VITNode vi [vit1, vit2]) ce@(fvs, AnnApp ce1 ce2) 
   = do { varsS <- varsSimple fvs 
        ; case (vi, varsS) of
-           (VISimple, True) -> do { let (e', vt') = encaps vt ce
+           (VISimple, True) -> do { let (e', vt') = liftSimple vt ce
                                   -- ; checkTreeAnnM vt' e'
                                   -- ; traceVt "Passed checkTree test!!" (ppr $ deAnnotate e')
                                   ; return (e', vt')
                                   }
-           _                -> do { (etaCe1, vit1') <- encapsulateScalar vit1 ce1
-                                  ; (etaCe2, vit2') <- encapsulateScalar vit2 ce2
+           _                -> do { (etaCe1, vit1') <- encapsulateScalars vit1 ce1
+                                  ; (etaCe2, vit2') <- encapsulateScalars vit2 ce2
                                   ; return ((fvs, AnnApp etaCe1 etaCe2), VITNode vi [vit1', vit2'])
                                   }
        }
-encapsulateScalar _  (_fvs, AnnApp _ce1 _ce2)                           
-  = panic "encapsulateScalar AnnApp doesn't match up"
+
+encapsulateScalars _  (_fvs, AnnApp _ce1 _ce2)                           
+  = panic "encapsulateScalars AnnApp doesn't match up"
   
-encapsulateScalar vt@(VITNode vi (scrutVit : altVits)) ce@(fvs, AnnCase scrut bndr ty alts) 
+encapsulateScalars vt@(VITNode vi (scrutVit : altVits)) ce@(fvs, AnnCase scrut bndr ty alts) 
   = do { varsS <- varsSimple fvs 
        ; case (vi, varsS) of
-           (VISimple, True) -> return $ encaps vt ce
-           _                -> do { (extScrut, scrutVit') <- encapsulateScalar scrutVit scrut
+           (VISimple, True) -> return $ liftSimple vt ce
+           _                -> do { (extScrut, scrutVit') <- encapsulateScalars scrutVit scrut
                                   ; extAltsVits  <- zipWithM expAlt altVits alts
                                   ; let (extAlts, altVits') = unzip extAltsVits
                                   ; return ((fvs, AnnCase extScrut bndr ty extAlts), VITNode vi (scrutVit': altVits'))
@@ -323,110 +172,100 @@ encapsulateScalar vt@(VITNode vi (scrutVit : altVits)) ce@(fvs, AnnCase scrut bn
        }
   where
     expAlt vt (con, bndrs, expr) 
-      = do { (extExpr, vt') <- encapsulateScalar vt expr
+      = do { (extExpr, vt') <- encapsulateScalars vt expr
            ; return ((con, bndrs, extExpr), vt')
            }
            
-encapsulateScalar _ (_fvs, AnnCase _scrut _bndr _ty _alts) 
-  = panic "encapsulateScalar AnnCase doesn't match up"
+encapsulateScalars _ (_fvs, AnnCase _scrut _bndr _ty _alts) 
+  = panic "encapsulateScalars AnnCase doesn't match up"
   
-encapsulateScalar vt@(VITNode vi [vt1, vt2]) ce@(fvs, AnnLet (AnnNonRec bndr expr1) expr2) 
+encapsulateScalars vt@(VITNode vi [vt1, vt2]) ce@(fvs, AnnLet (AnnNonRec bndr expr1) expr2) 
   = do { varsS <- varsSimple fvs 
        ; case (vi, varsS) of
-           (VISimple, True) -> return $ encaps vt ce
-           _                -> do { (extExpr1, vt1') <- encapsulateScalar vt1 expr1
-                                  ; (extExpr2, vt2') <- encapsulateScalar vt2 expr2
+           (VISimple, True) -> return $ liftSimple vt ce
+           _                -> do { (extExpr1, vt1') <- encapsulateScalars vt1 expr1
+                                  ; (extExpr2, vt2') <- encapsulateScalars vt2 expr2
                                   ; return ((fvs, AnnLet (AnnNonRec bndr extExpr1) extExpr2), VITNode vi [vt1', vt2'])
                                   }
        }
 
-encapsulateScalar _ (_fvs, AnnLet (AnnNonRec _bndr _expr1) _expr2)       
-  = panic "encapsulateScalar AnnLet nonrec doesn't match up"
+encapsulateScalars _ (_fvs, AnnLet (AnnNonRec _bndr _expr1) _expr2)       
+  = panic "encapsulateScalars AnnLet nonrec doesn't match up"
          
-encapsulateScalar vt@(VITNode vi (vtB : vtBnds)) ce@(fvs, AnnLet (AnnRec bndngs) expr) 
+encapsulateScalars vt@(VITNode vi (vtB : vtBnds)) ce@(fvs, AnnLet (AnnRec bndngs) expr) 
   = do { varsS <- varsSimple fvs 
        ; case (vi, varsS) of 
-           (VISimple, True) -> return $ encaps vt ce
+           (VISimple, True) -> return $ liftSimple vt ce
            _                -> do { extBndsVts <- zipWithM expBndg vtBnds bndngs
                                   ; let (extBnds, vtBnds') = unzip extBndsVts
-                                  ; (extExpr, vtB') <- encapsulateScalar vtB expr
+                                  ; (extExpr, vtB') <- encapsulateScalars vtB expr
                                   ; let vt' = VITNode vi (vtB':vtBnds')
                                   ; return ((fvs, AnnLet (AnnRec extBnds) extExpr), vt')
                                   }
        }                            
     where
       expBndg vit (bndr, expr) 
-        = do { (extExpr, vit') <- encapsulateScalar vit expr
+        = do { (extExpr, vit') <- encapsulateScalars vit expr
              ; return  ((bndr, extExpr), vit')
              }
        
-encapsulateScalar _ (_fvs, AnnLet (AnnRec _) _expr2)       
-  = panic "encapsulateScalar AnnLet rec doesn't match up"
+encapsulateScalars _ (_fvs, AnnLet (AnnRec _) _expr2)       
+  = panic "encapsulateScalars AnnLet rec doesn't match up"
 
-
-           
-encapsulateScalar (VITNode vi [vit]) (fvs, AnnCast expr coercion)
-  = do { (extExpr, vit') <- encapsulateScalar  vit expr
+encapsulateScalars (VITNode vi [vit]) (fvs, AnnCast expr coercion)
+  = do { (extExpr, vit') <- encapsulateScalars  vit expr
        ; return ((fvs, AnnCast extExpr coercion), VITNode vi [vit'])
        }
        
-encapsulateScalar  _ (_fvs, AnnCast _expr _coercion) 
-  = panic "encapsulateScalar AnnCast rec doesn't match up"
-
-    
-encapsulateScalar _ _  
-  = panic "encapsulateScalar case not handled"
+encapsulateScalars  _ (_fvs, AnnCast _expr _coercion) 
+  = panic "encapsulateScalars AnnCast rec doesn't match up"
     
+encapsulateScalars _ _  
+  = panic "encapsulateScalars case not handled"
 
-  
-  
---  CoreExprWithFVs,        -- = AnnExpr Id VarSet
---  AnnExpr bndr VarSet = (annot, AnnExpr' bndr VarSet)
---  AnnLam :: bndr -> (AnnExpr bndr VarSet) -> AnnExpr' bndr VarSet
---  AnnLam bndr (AnnExpr bndr annot)      
-encaps :: VITree -> CoreExprWithFVs -> (CoreExprWithFVs, VITree)
-encaps (VITNode vi (scrutVit : altVits)) (fvs, AnnCase expr bndr t alts) 
+-- Lambda-lift the given expression and apply it to the abstracted free variables.
+--
+-- If the expression is a case expression scrutinising anything but a primitive type, then lift
+-- each alternative individually.
+--
+liftSimple :: VITree -> CoreExprWithFVs -> (CoreExprWithFVs, VITree)
+liftSimple (VITNode vi (scrutVit : altVits)) (fvs, AnnCase expr bndr t alts) 
   | Just (c,_) <- splitTyConApp_maybe (exprType $ deAnnotate $ expr),  
-    (not $ elem c [boolTyCon, intTyCon, doubleTyCon, floatTyCon])   -- TODO: globalScalarTyCons
-     = ((fvs, AnnCase expr bndr t alts'), VITNode vi (scrutVit : altVits'))
-      
-     where 
-       (alts', altVits') = unzip $ map (\(ac,bndrs, (alt, avi)) -> ((ac,bndrs,alt), avi)) $ 
-                           zipWith  (\(ac, bndrs, aex) -> \altVi -> (ac, bndrs, encaps altVi aex)) alts altVits
-         
-encaps viTree ae@(fvs, _annEx) 
+    (not $ elem c [boolTyCon, intTyCon, doubleTyCon, floatTyCon])   -- FIXME: shouldn't be hardcoded
+     = ((fvs, AnnCase expr bndr t alts'), VITNode vi (scrutVit : altVits'))      
+  where 
+    (alts', altVits') = unzip $ map (\(ac,bndrs, (alt, avi)) -> ((ac,bndrs,alt), avi)) $ 
+                        zipWith  (\(ac, bndrs, aex) -> \altVi -> (ac, bndrs, liftSimple altVi aex)) alts altVits
+          
+liftSimple viTree ae@(fvs, _annEx) 
   = (mkAnnApps (mkAnnLams ae vars) vars, viTree')
   where
-      mkViTreeLams (VITNode _ vits) [] = VITNode VIEncaps vits
-      mkViTreeLams vi (_:vs) = VITNode VIEncaps [mkViTreeLams vi vs]
+    mkViTreeLams (VITNode _ vits) [] = VITNode VIEncaps vits
+    mkViTreeLams vi (_:vs) = VITNode VIEncaps [mkViTreeLams vi vs]
 
-      mkViTreeApps vi []      = vi
-      mkViTreeApps vi (_:vs)  = VITNode VISimple [mkViTreeApps vi vs, VITNode VISimple []]
+    mkViTreeApps vi []      = vi
+    mkViTreeApps vi (_:vs)  = VITNode VISimple [mkViTreeApps vi vs, VITNode VISimple []]
+    
+    vars    = varSetElems fvs
+    viTree' = mkViTreeApps (mkViTreeLams viTree vars) vars
+    
+    mkAnnLam :: bndr -> AnnExpr bndr VarSet -> AnnExpr' bndr VarSet
+    mkAnnLam bndr ce = AnnLam bndr ce         
       
-      vars    = varSetElems fvs
-      viTree' = mkViTreeApps (mkViTreeLams viTree vars) vars
+    mkAnnLams:: CoreExprWithFVs -> [Var] -> CoreExprWithFVs
+    mkAnnLams (fv, aex') []     = (fv, aex')  -- fv should be empty. check!
+    mkAnnLams (fv, aex') (v:vs) = mkAnnLams (delVarSet fv v, (mkAnnLam v ((delVarSet fv v), aex'))) vs
       
-      mkAnnLam :: bndr -> AnnExpr bndr VarSet -> AnnExpr' bndr VarSet
-      mkAnnLam bndr ce = AnnLam bndr ce         
-        
-      mkAnnLams:: CoreExprWithFVs -> [Var] -> CoreExprWithFVs
-      mkAnnLams (fv, aex') []     = (fv, aex')  -- fv should be empty. check!
-      mkAnnLams (fv, aex') (v:vs) = mkAnnLams (delVarSet fv v, (mkAnnLam v ((delVarSet fv v), aex'))) vs
-        
-      mkAnnApp :: (AnnExpr bndr VarSet) -> Var -> (AnnExpr' bndr VarSet)
-      mkAnnApp aex v = AnnApp aex (unitVarSet v, (AnnVar v))
-        
-      mkAnnApps:: CoreExprWithFVs -> [Var] -> CoreExprWithFVs
-      mkAnnApps (fv, aex') [] = (fv, aex')
-      mkAnnApps ae (v:vs) = 
-        let
-          (fv, aex') = mkAnnApps ae vs
-        in (extendVarSet fv v, mkAnnApp (fv, aex') v)
-
-
-
+    mkAnnApp :: (AnnExpr bndr VarSet) -> Var -> (AnnExpr' bndr VarSet)
+    mkAnnApp aex v = AnnApp aex (unitVarSet v, (AnnVar v))
+      
+    mkAnnApps:: CoreExprWithFVs -> [Var] -> CoreExprWithFVs
+    mkAnnApps (fv, aex') [] = (fv, aex')
+    mkAnnApps ae (v:vs) = 
+      let
+        (fv, aex') = mkAnnApps ae vs
+      in (extendVarSet fv v, mkAnnApp (fv, aex') v)
 
-    
 -- |Vectorise an expression.
 --
 vectExpr :: CoreExprWithFVs -> VITree -> VM VExpr
@@ -441,6 +280,7 @@ vectExpr (_, AnnLit lit) _
 
 vectExpr e@(_, AnnLam bndr _) vt
   | isId bndr = (\(_, _, ve) -> ve) <$> vectFnExpr True False [] e vt
+  | otherwise = cantVectorise "Unexpected type lambda (vectExpr)" (ppr (deAnnotate e))
 
   -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty';
   --   its only purpose is to abort the program, but we need to adjust the type to keep CoreLint
@@ -501,7 +341,7 @@ vectExpr (_, AnnCase scrut bndr ty alts)  vt
 
 vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) (VITNode _ [vt1, vt2]) 
   = do
-      vrhs <- localV . inBind bndr . liftM (\(_,_,z)->z) $ vectPolyExprVT False [] rhs vt1
+      vrhs <- localV . inBind bndr . liftM (\(_,_,z)->z) $ vectPolyExpr False [] rhs (Just vt1)
       (vbndr, vbody) <- vectBndrIn bndr (vectExpr body vt2)
       return $ vLet (vNonRec vbndr vrhs) vbody
 
@@ -518,7 +358,7 @@ vectExpr (_, AnnLet (AnnRec bs) body) (VITNode _ (vtB : vtBnds))
     vect_rhs bndr rhs vt = localV
                          . inBind bndr
                          . liftM (\(_,_,z)->z)
-                         $ vectPolyExprVT (isStrongLoopBreaker $ idOccInfo bndr) [] rhs vt
+                         $ vectPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) [] rhs (Just vt)
     zipWith3M f xs ys zs = zipWithM (\x -> \(y,z) -> (f x y z)) xs (zip ys zs)
 
 vectExpr (_, AnnTick tickish expr)  (VITNode _ [vit])
@@ -527,7 +367,7 @@ vectExpr (_, AnnTick tickish expr)  (VITNode _ [vit])
 vectExpr (_, AnnType ty) _
   = liftM vType (vectType ty)
 
-vectExpr e  _ = cantVectorise "Can't vectorise expression (vectExpr)" (ppr $ deAnnotate e)
+vectExpr e vit = cantVectorise "Can't vectorise expression (vectExpr)" (ppr (deAnnotate e) $$ text ("  " ++ show vit))
 
 -- |Vectorise an expression that *may* have an outer lambda abstraction.
 --
@@ -542,11 +382,8 @@ vectFnExpr :: Bool             -- ^ If we process the RHS of a binding, whether
            -> CoreExprWithFVs  -- ^ Expression to vectorise; must have an outer `AnnLam`
            -> VITree
            -> VM (Inline, Bool, VExpr)
-
 -- vectFnExpr _ _ _ e vi | not (checkTree vi (deAnnotate e))
 --   = pprPanic "vectFnExpr" (ppr $ deAnnotate e)
- 
-           
 vectFnExpr inline loop_breaker recFns expr@(_fvs, AnnLam bndr body) vt@(VITNode _ [vt'])
       -- predicate abstraction: leave as a normal abstraction, but vectorise the predicate type
   | isId bndr
@@ -557,7 +394,7 @@ vectFnExpr inline loop_breaker recFns expr@(_fvs, AnnLam bndr body) vt@(VITNode
        }
       -- non-predicate abstraction: vectorise (try to vectorise as a scalar computation)
   | isId bndr
-  = mark DontInline True (vectScalarFunVT False recFns (deAnnotate expr) vt)
+  = mark DontInline True (vectScalarFunMaybe (deAnnotate expr) vt)
     `orElseV` 
     mark inlineMe False (vectLam inline loop_breaker expr vt)
 vectFnExpr _ _ _  e vt
@@ -689,144 +526,28 @@ vectDictExpr (Coercion coe)
 -- instead they become dictionaries of vectorised methods).  We treat them differently, though see
 -- "Note [Scalar dfuns]" in 'Vectorise'.
 --
-vectScalarFun :: [Var]      -- ^ Functions names in same recursive binding group
-              -> CoreExpr   -- ^ Expression to be vectorised
-              -> VM VExpr
-vectScalarFun recFns expr 
- -- this is an external call to vectScalarFun, so we pass a dummy vt tree. The only
- -- relevant bit is that the node info is *not* VIEncaps
- = vectScalarFunVT True recFns expr (VITNode VISimple []) 
-
-
-vectScalarFunVT :: Bool       -- ^ Was the function marked as scalar by the user?
-              -> [Var]      -- ^ Functions names in same recursive binding group
-              -> CoreExpr   -- ^ Expression to be vectorised
-              -> VITree
-              -> VM VExpr
-vectScalarFunVT forceScalar recFns expr (VITNode vi _)
- = do { gscalarVars  <- globalScalarVars
-      ; scalarTyCons <- globalScalarTyCons
-      ; let scalarVars = gscalarVars `extendVarSetList` recFns
-            (arg_tys, res_ty) = splitFunTys (exprType expr)
-      ; MASSERT( not $ null arg_tys )
-      ; traceVt  ("vectScalarFun - not scalar? "  ++ 
-                   "\n\tall tycons scalar? : " ++ (show $all (is_scalar_ty scalarTyCons) arg_tys) ++
-                   "\n\tresult  scalar?    : " ++ (show $is_scalar_ty scalarTyCons res_ty) ++
-                   "\n\tscalar body?       : " ++ (show $is_scalar scalarVars (is_scalar_ty scalarTyCons) expr) ++
-                   "\n\tuses vars?         : " ++ (show $uses scalarVars expr) ++
-                   "\n\t is encaps? (same as & of all prev cond): " ++ (show vi)
-                  )
-           (ppr expr)
-       ; onlyIfV (ptext (sLit "not a scalar function"))
-                 (forceScalar                              -- user asserts the functions is scalar
-                  ||
-                  (vi == VIEncaps))                         -- should only be true if all the foll. cond are hold
-
-{-                  ||
-                  all (is_scalar_ty scalarTyCons) arg_tys  -- check whether the function is scalar
-                   && is_scalar_ty scalarTyCons res_ty
-                   && is_scalar scalarVars (is_scalar_ty scalarTyCons) expr
-                   && uses scalarVars expr)
- -}
-         $ do { traceVt  "vectScalarFun - is scalar"  (ppr expr) 
-              ;  mkScalarFun arg_tys res_ty expr
-              }
-       }      
-  where
-    {-
-    -- !!!FIXME: We would like to allow scalar functions with arguments and results that can be
-    --           any 'scalarTyCons', but can't at the moment, as those argument and result types
-    --           need to be members of the 'Scalar' class (that in its current form would better
-    --           be called 'Primitive'). *ALSO* the hardcoded list of types is ugly!
-    -}
-    is_scalar_ty _scalarTyCons ty 
-      | isPredTy ty               -- dictionaries never get into the environment
-      = True
-      | Just (tycon, []) <- splitTyConApp_maybe ty  -- TODO: FIX THIS!
-      = tyConName tycon `elem` [boolTyConName, intTyConName, word8TyConName, doubleTyConName, floatTyConName]      
--- FIXME:      = tyConName tycon `elemNameSet` scalarTyCons      
-      | Just (tycon, _) <- splitTyConApp_maybe ty
-      = tyConName tycon `elem` [boolTyConName, intTyConName, word8TyConName, doubleTyConName, floatTyConName]      
-      
--- FIXME:     = tyConName tycon `elemNameSet` scalarTyCons
-      | otherwise 
-      = False
-
-    -- Checks whether an expression contain a non-scalar subexpression. 
-    --
-    -- Precodition: The variables in the first argument are scalar.
-    --
-    -- In case of a recursive binding group, we /assume/ that all bindings are scalar (by adding
-    -- them to the list of scalar variables) and then check them.  If one of them turns out not to
-    -- be scalar, the entire group is regarded as not being scalar.
-    --
-    -- The second argument is a predicate that checks whether a type is scalar.
-    --
-    is_scalar :: VarSet -> (Type -> Bool) -> CoreExpr -> Bool
-    is_scalar scalars  _isScalarTC (Var v)         = 
-      v `elemVarSet` scalars
-    is_scalar _scalars _isScalarTC (Lit _)         = True
-    is_scalar scalars  isScalarTC  (App e1 e2)   = is_scalar scalars isScalarTC e1 && 
-                                                      is_scalar scalars isScalarTC e2
-    is_scalar scalars  isScalarTC  (Lam var body)  
-      | maybe_parr_ty (varType var)                 = False
-      | otherwise                                   = is_scalar (scalars `extendVarSet` var)
-                                                               isScalarTC body
-    is_scalar scalars  isScalarTC  (Let bind body) =  trace ("is_scalar LET "  ++ (show bindsAreScalar ) ++ 
-                                                             "   " ++ (show $ is_scalar scalars' isScalarTC body)  ++ 
-                                                             (show $ showSDoc $ ppr bind))  $
-                                                     bindsAreScalar && 
-                                                     is_scalar scalars' isScalarTC body
-      where
-        (bindsAreScalar, scalars') = is_scalar_bind scalars isScalarTC bind
-    is_scalar scalars  isScalarTC  (Case e var ty alts)
-      | isScalarTC ty                  = is_scalar scalars' isScalarTC e && 
-                                         all (is_scalar_alt scalars' isScalarTC) alts
-      | otherwise                      = False
-      where
-        scalars' = scalars `extendVarSet` var
-    is_scalar scalars  isScalarTC  (Cast e _coe)   = is_scalar scalars isScalarTC e
-    is_scalar scalars  isScalarTC  (Tick _ e   )   = is_scalar scalars isScalarTC e
-    is_scalar _scalars _isScalarTC (Type {})       = True
-    is_scalar _scalars _isScalarTC (Coercion {})   = True
-
-    -- Result: (<is this binding group scalar>, scalars ++ variables bound in this group)
-    is_scalar_bind scalars isScalarTCs (NonRec var e) = (is_scalar scalars isScalarTCs e, 
-                                                         scalars `extendVarSet` var)
-    is_scalar_bind scalars isScalarTCs (Rec bnds)     = (all (is_scalar scalars' isScalarTCs) es,
-                                                         scalars')
-      where
-        (vars, es) = unzip bnds
-        scalars'   = scalars `extendVarSetList` vars
-
-    is_scalar_alt scalars isScalarTCs (_, vars, e) = is_scalar (scalars `extendVarSetList ` vars)
-                                                               isScalarTCs e
-
-    -- Checks whether the type might be a parallel array type.  In particular, if the outermost
-    -- constructor is a type family, we conservatively assume that it may be a parallel array type.
-    maybe_parr_ty :: Type -> Bool
-    maybe_parr_ty ty 
-      | Just ty'        <- coreView ty            = maybe_parr_ty ty'
-      | Just (tyCon, _) <- splitTyConApp_maybe ty = isPArrTyCon tyCon || isSynFamilyTyCon tyCon 
-    maybe_parr_ty _                               = False
-
-    -- FIXME: I'm not convinced that this reasoning is (always) sound.  If the identify functions
-    --        is called by some other function that is otherwise scalar, it would be very bad
-    --        that just this call to the identity makes it not be scalar.
-    -- A scalar function has to actually compute something. Without the check,
-    -- we would treat (\(x :: Int) -> x) as a scalar function and lift it to
-    -- (map (\x -> x)) which is very bad. Normal lifting transforms it to
-    -- (\n# x -> x) which is what we want.
-    uses funs (Var v)       = v `elemVarSet` funs 
-    uses funs (App e1 e2)   = uses funs e1 || uses funs e2
-    uses funs (Lam b body)  = uses (funs `extendVarSet` b) body
-    uses funs (Let (NonRec _b letExpr) body) 
-                            = uses funs letExpr || uses funs  body
-    uses funs (Case e _eId _ty alts) 
-                            = uses funs e || any (uses_alt funs) alts
-    uses _ _                = False
-
-    uses_alt funs (_, _bs, e) = uses funs e 
+vectScalarFunMaybe :: CoreExpr   -- ^ Expression to be vectorised
+                   -> VITree     -- ^ Vectorisation information
+                   -> VM VExpr
+vectScalarFunMaybe expr  (VITNode VIEncaps _) = vectScalarFun expr
+vectScalarFunMaybe _expr _                    = noV $ ptext (sLit "not a scalar function")
+
+-- |Vectorise an expression of functional type by lifting it by an application of a member of the
+-- zipWith family (i.e., 'map', 'zipWith', zipWith3', etc.)  This is only a valid strategy if the
+-- function does not contain parallel subcomputations and has only 'Scalar' types in its result and
+-- arguments — this is a predcondition for calling this function.
+--
+-- Dictionary functions are also scalar functions (as dictionaries themselves are not vectorised,
+-- instead they become dictionaries of vectorised methods).  We treat them differently, though see
+-- "Note [Scalar dfuns]" in 'Vectorise'.
+--
+vectScalarFun :: CoreExpr -> VM VExpr
+vectScalarFun expr 
+  = do 
+    { traceVt "vectScalarFun" (ppr expr) 
+    ; let (arg_tys, res_ty) = splitFunTys (exprType expr)
+    ; mkScalarFun arg_tys res_ty expr
+    }
 
 -- Generate code for a scalar function by generating a scalar closure.  If the function is a
 -- dictionary function, vectorise it as dictionary code.
@@ -883,9 +604,8 @@ mkScalarFun arg_tys res_ty expr
 --   the application of the unvectorised dfun, to enable the dictionary selection rules to fire.
 --
 vectScalarDFun :: Var        -- ^ Original dfun
-               -> [Var]      -- ^ Functions names in same recursive binding group
                -> VM CoreExpr
-vectScalarDFun var recFns
+vectScalarDFun var
   = do {   -- bring the type variables into scope
        ; mapM_ defLocalTyVar tvs
 
@@ -901,7 +621,7 @@ vectScalarDFun var recFns
              dict           = Var var `mkTyApps` (mkTyVarTys tvs) `mkVarApps` thetaVars
              scsOps         = map (\selId -> varToCoreExpr selId `mkTyApps` tys `mkApps` [dict])
                                   selIds
-       ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun recFns e) scsOps
+       ; vScsOps <- mapM (\e -> vectorised <$> vectScalarFun e) scsOps
 
            -- vectorised applications of the class-dictionary data constructor
        ; Just vDataCon <- lookupDataCon dataCon
@@ -943,7 +663,7 @@ unVectDict ty e
                                        Nothing  -> panic "Vectorise.Exp.unVectDict: no class"
     selIds                         = classAllSelIds cls
 
--- |Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures.
+-- Vectorise an 'n'-ary lambda abstraction by building a set of 'n' explicit closures.
 --
 -- All non-dictionary free variables go into the closure's environment, whereas the dictionary
 -- variables are passed explicit (as conventional arguments) into the body during closure
@@ -1013,8 +733,9 @@ vectLam inline loop_breaker expr@(fvs, AnnLam _ _)  vi
       | otherwise = return (ve, le)
 vectLam _ _ _ _ = panic "vectLam"
 
--- | Vectorise an algebraic case expression.
---   We convert
+-- Vectorise an algebraic case expression.
+--
+-- We convert
 --
 --   case e :: t of v { ... }
 --
@@ -1167,9 +888,172 @@ vectAlgCase tycon _ty_args scrut bndr ty alts (VITNode _ (scrutVit : altVits))
 
             _ -> return []
             
-vectAlgCase tycon _ty_args _scrut _bndr _ty _alts (VITNode _ [])
+vectAlgCase tycon _ty_args _scrut _bndr _ty _alts (VITNode _ _)
   = pprPanic "vectAlgCase (mismatched node information)" (ppr tycon)
 
+
+-- Support to compute information for vectorisation avoidance ------------------
+
+-- Annotation for Core AST nodes that describes how they should be handled during vectorisation
+-- and especially if vectorisation of the corresponding computation can be avoided.
+--
+data VectAvoidInfo = VIParr       -- tree contains parallel computations
+                   | VISimple     -- result type is scalar & no parallel subcomputation
+                   | VIComplex    -- any result type, no parallel subcomputation
+                   | VIEncaps     -- tree encapsulated by 'liftSimple'
+                   deriving (Eq, Show)
+
+-- Instead of integrating the vectorisation avoidance information into Core expression, we keep
+-- them in a separate tree (that structurally mirrors the Core expression that it annotates).
+--
+data VITree = VITNode VectAvoidInfo [VITree] 
+            deriving (Show)
+
+-- Is any of the tree nodes a 'VIPArr' node?
+--
+anyVIPArr :: [VITree] -> Bool
+anyVIPArr = or . (map (\(VITNode vi _) -> vi == VIParr))
+
+-- Compute Core annotations to determine for which subexpressions we can avoid vectorisation
+--
+-- FIXME: free scalar vars don't actually need to be passed through, since encapsulations makes sure,
+--        that there are no free variables in encapsulated lambda expressions     
+vectAvoidInfo :: CoreExprWithFVs -> VM VITree
+vectAvoidInfo ce@(_, AnnVar v) 
+  = do { vi <- vectAvoidInfoType $ exprType $ deAnnotate ce
+       ; viTrace ce vi [] 
+       ; traceVt "vectAvoidInfo AnnVar" ((ppr v) <+> (ppr $ exprType $ deAnnotate ce))
+       ; return $ VITNode vi []
+       }
+
+vectAvoidInfo ce@(_, AnnLit _)     
+  = do { vi <- vectAvoidInfoType $ exprType $ deAnnotate ce  
+       ; viTrace ce vi [] 
+       ; traceVt "vectAvoidInfo AnnLit" (ppr $ exprType $ deAnnotate ce)       
+       ; return $ VITNode vi []
+       }
+
+vectAvoidInfo ce@(_, AnnApp e1 e2)  
+  = do { vt1  <- vectAvoidInfo e1  
+       ; vt2  <- vectAvoidInfo e2  
+       ; vi <- if anyVIPArr [vt1, vt2] 
+                    then return VIParr
+                    else vectAvoidInfoType $ exprType $ deAnnotate ce
+       ; viTrace ce vi [vt1, vt2]                     
+       ; return $ VITNode vi [vt1, vt2]
+       }
+
+vectAvoidInfo ce@(_, AnnLam _var body) 
+  = do { vt@(VITNode vi _) <- vectAvoidInfo body  
+       ; viTrace ce vi [vt]
+       ; let resultVI | vi == VIParr = VIParr
+                      | otherwise    = VIComplex
+       ; return $ VITNode resultVI [vt]
+       }
+
+vectAvoidInfo ce@(_, AnnLet (AnnNonRec _var expr) body)  
+  = do { vtE <- vectAvoidInfo expr 
+       ; vtB <- vectAvoidInfo body 
+       ; vi <- if anyVIPArr [vtE, vtB] 
+                 then return VIParr
+                 else vectAvoidInfoType $ exprType $ deAnnotate ce
+       ; viTrace ce vi [vtE, vtB]                                          
+       ; return $ VITNode vi [vtE, vtB]
+       }
+
+vectAvoidInfo ce@(_, AnnLet (AnnRec bnds) body)  
+  = do { let (_, exprs) = unzip bnds
+       ; vtBnds <- mapM (\e -> vectAvoidInfo e) exprs
+       ; if (anyVIPArr vtBnds)
+            then do { vtBnds' <- mapM (\e -> vectAvoidInfo e) exprs    
+                    ; vtB <- vectAvoidInfo body 
+                    ; return (VITNode VIParr (vtB: vtBnds'))
+                    }
+            else do { vtB@(VITNode vib _)  <- vectAvoidInfo body 
+                    ; ni <- if (vib == VIParr) 
+                               then return VIParr
+                               else vectAvoidInfoType $ exprType $ deAnnotate ce
+                    ; viTrace ce ni (vtB : vtBnds)                                        
+                    ; return $ VITNode ni (vtB : vtBnds)
+                    }
+       }
+
+vectAvoidInfo ce@(_, AnnCase expr _var _ty alts) 
+  = do { vtExpr <- vectAvoidInfo expr 
+       ; vtAlts <- mapM (\(_, _, e) -> vectAvoidInfo e) alts
+       ; ni <- if anyVIPArr (vtExpr : vtAlts)
+                 then return VIParr
+                 else vectAvoidInfoType $ exprType $ deAnnotate ce
+       ; viTrace ce ni (vtExpr  : vtAlts)
+       ; return $ VITNode ni (vtExpr: vtAlts)
+       }
+
+vectAvoidInfo (_, AnnCast expr _)       
+  = do { vt@(VITNode vi _) <- vectAvoidInfo expr 
+       ; return $ VITNode vi [vt]
+       }
+
+vectAvoidInfo (_, AnnTick _ expr)       
+  = do { vt@(VITNode vi _) <- vectAvoidInfo expr 
+       ; return $ VITNode vi [vt]
+       }
+
+vectAvoidInfo (_, AnnType {})  
+  = return $ VITNode VISimple []
+
+vectAvoidInfo (_, AnnCoercion {}) 
+  = return $ VITNode VISimple []
+
+-- Compute vectorisation avoidance information for a type.
+--
+vectAvoidInfoType :: Type -> VM VectAvoidInfo   
+vectAvoidInfoType ty 
+  | maybeParrTy ty = return VIParr
+  | otherwise      
+  = do { sType <- isSimpleType ty
+       ; if sType 
+           then return VISimple
+           else return VIComplex
+       }
+
+-- Checks whether the type might be a parallel array type.  In particular, if the outermost
+-- constructor is a type family, we conservatively assume that it may be a parallel array type.
+--
+maybeParrTy :: Type -> Bool
+maybeParrTy ty 
+    | Just ty'         <- coreView ty            = maybeParrTy ty'
+    | Just (tyCon, ts) <- splitTyConApp_maybe ty = isPArrTyCon tyCon || isSynFamilyTyCon tyCon  
+                                                 || or (map maybeParrTy ts)
+maybeParrTy _  = False               
+
+-- FIXME: This should not be hardcoded.
+isSimpleType :: Type -> VM Bool
+isSimpleType ty 
+  | Just (c, _cs) <- splitTyConApp_maybe ty 
+  = return $ (tyConName c) `elem` [boolTyConName, intTyConName, word8TyConName, doubleTyConName, floatTyConName]
+{-
+    = do { globals <- globalScalarTyCons
+          ; traceVt ("isSimpleType " ++ (show (elemNameSet (tyConName c) globals ))) (ppr c)  
+          ; return (elemNameSet (tyConName c) globals ) 
+          } 
+  -}
+  | Nothing <- splitTyConApp_maybe ty
+    = return False
+isSimpleType ty 
+  = pprPanic "Vectorise.Exp.isSimpleType not handled" (ppr ty)
+
+varsSimple :: VarSet -> VM Bool
+varsSimple vs 
+  = do { varTypes <- mapM isSimpleType $ map varType $  varSetElems vs
+       ; return $ and varTypes
+       }
+
+viTrace :: CoreExprWithFVs -> VectAvoidInfo -> [VITree] -> VM ()
+viTrace ce vi vTs
+  = traceVt ("vitrace " ++ (show vi) ++ "[" ++ (concat $ map (\(VITNode vi _) -> show vi ++ " ") vTs) ++"]") 
+            (ppr $ deAnnotate ce)
+
+
 {-
 ---- Sanity check  of the tree, for debugging only
 checkTree :: VITree -> CoreExpr -> Bool
@@ -1178,44 +1062,33 @@ checkTree  (VITNode _ []) (Type _ty)
       
 checkTree  (VITNode _ [])  (Var _v)  
   = True
-
   
 checkTree  (VITNode _ [])  (Lit _)
   = True
-  
          
 checkTree (VITNode _ [vit]) (Tick _ expr)
   = checkTree vit expr
-
-  
   
 checkTree (VITNode _ [vit]) (Lam _ expr) 
   = checkTree vit expr
-
   
 checkTree (VITNode _ [vit1, vit2])  (App ce1 ce2) 
   = (checkTree vit1 ce1) && (checkTree vit2 ce2) 
-
-     
-    
+        
 checkTree (VITNode _ (scrutVit : altVits)) (Case scrut _ _ alts) 
   = (checkTree scrutVit scrut) && (and $ zipWith checkAlt altVits alts)
   where
     checkAlt vt (_, _, expr) = checkTree vt expr
     
-
 checkTree (VITNode _ [vt1, vt2]) (Let (NonRec _ expr1) expr2) 
   = (checkTree vt1 expr1) && (checkTree vt2 expr2) 
 
-
-
 checkTree (VITNode _ (vtB : vtBnds))  (Let (Rec bndngs) expr) 
   = (and $ zipWith checkBndr vtBnds bndngs) && 
     (checkTree vtB expr)
  where 
    checkBndr vt (_, e) = checkTree vt e
-   
-           
+              
 checkTree (VITNode _ [vit]) (Cast expr _)
   = checkTree vit expr