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

67 files changed, 2020 insertions, 1659 deletions

diff --git a/aclocal.m4 b/aclocal.m4
index c196bdf026..f05dfe96ea 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -1808,7 +1808,7 @@ AC_MSG_NOTICE(Building in-tree ghc-pwd)
     dnl except we don't want to have to know what make is called. Sigh.
     rm -rf utils/ghc-pwd/dist-boot
     mkdir  utils/ghc-pwd/dist-boot
-    if ! "$WithGhc" -v0 -no-user-package-conf -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd
+    if ! "$WithGhc" -v0 -no-user-$GHC_PACKAGE_DB_FLAG -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd
     then
         AC_MSG_ERROR([Building ghc-pwd failed])
     fi
diff --git a/bindisttest/Makefile b/bindisttest/Makefile
index 238bce7650..7d20bdbf39 100644
--- a/bindisttest/Makefile
+++ b/bindisttest/Makefile
@@ -48,8 +48,8 @@ endif
 	$(BIN_DIST_INST_DIR)/bin/ghc --make HelloWorld
 	./HelloWorld > output
 	$(CONTEXT_DIFF) output expected_output
-# Without --no-user-package-conf we might pick up random packages from ~/.ghc
-	$(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-conf
+# Without --no-user-package-db we might pick up random packages from ~/.ghc
+	$(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-db
 
 clean distclean:
 	"$(RM)" $(RM_OPTS_REC) $(BIN_DIST_INST_SUBDIR)
diff --git a/bindisttest/ghc.mk b/bindisttest/ghc.mk
index e051be0ccd..c911da5e8c 100644
--- a/bindisttest/ghc.mk
+++ b/bindisttest/ghc.mk
@@ -48,8 +48,8 @@ endif
 	$(BIN_DIST_INST_DIR)/bin/ghc --make bindisttest/HelloWorld
 	bindisttest/HelloWorld > bindisttest/output
 	$(CONTEXT_DIFF) bindisttest/output bindisttest/expected_output
-# Without --no-user-package-conf we might pick up random packages from ~/.ghc
-	$(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-conf
+# Without --no-user-package-db we might pick up random packages from ~/.ghc
+	$(BIN_DIST_INST_DIR)/bin/ghc-pkg check --no-user-package-db
 
 $(eval $(call clean-target,bindisttest,all,$(BIN_DIST_INST_DIR) $(wildcard bindisttest/a/b/c/*) bindisttest/HelloWorld bindisttest/HelloWorld.o bindisttest/HelloWorld.hi bindisttest/output))
 
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index 29fe407e50..bfe6dec72e 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -649,7 +649,7 @@ data Unfolding
 		      			--	a `seq` on this variable
         uf_is_conlike :: Bool,          -- True <=> applicn of constructor or CONLIKE function
                                         --      Cached version of exprIsConLike
-	uf_is_cheap   :: Bool,		-- True <=> doesn't waste (much) work to expand 
+	uf_is_work_free :: Bool,		-- True <=> doesn't waste (much) work to expand 
                                         --          inside an inlining
 					-- 	Cached version of exprIsCheap
 	uf_expandable :: Bool,		-- True <=> can expand in RULE matching
@@ -667,8 +667,8 @@ data Unfolding
   --  uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
   --     this variable
   --
-  --  uf_is_cheap:  Does this waste only a little work if we expand it inside an inlining?
-  --     Basically this is a cached version of 'exprIsCheap'
+  --  uf_is_work_free:  Does this waste only a little work if we expand it inside an inlining?
+  --     Basically this is a cached version of 'exprIsWorkFree'
   --
   --  uf_guidance:  Tells us about the /size/ of the unfolding template
 
@@ -787,7 +787,7 @@ mkOtherCon = OtherCon
 
 seqUnfolding :: Unfolding -> ()
 seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, 
-		uf_is_value = b1, uf_is_cheap = b2, 
+		uf_is_value = b1, uf_is_work_free = b2, 
 	   	uf_expandable = b3, uf_is_conlike = b4,
                 uf_arity = a, uf_guidance = g})
   = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
@@ -850,8 +850,8 @@ isConLikeUnfolding _                                        = False
 
 -- | Is the thing we will unfold into certainly cheap?
 isCheapUnfolding :: Unfolding -> Bool
-isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap
-isCheapUnfolding _                                          = False
+isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf
+isCheapUnfolding _                                           = False
 
 isExpandableUnfolding :: Unfolding -> Bool
 isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 4529dba20d..5817669fe7 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -145,15 +145,15 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
                 -> Arity -> UnfoldingGuidance -> Unfolding
 -- Occurrence-analyses the expression before capturing it
 mkCoreUnfolding src top_lvl expr arity guidance 
-  = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
-    		    uf_src        = src,
-    		    uf_arity      = arity,
-		    uf_is_top 	  = top_lvl,
-		    uf_is_value   = exprIsHNF        expr,
-                    uf_is_conlike = exprIsConLike    expr,
-		    uf_is_cheap   = exprIsCheap      expr,
-		    uf_expandable = exprIsExpandable expr,
-		    uf_guidance   = guidance }
+  = CoreUnfolding { uf_tmpl   	    = occurAnalyseExpr expr,
+    		    uf_src          = src,
+    		    uf_arity        = arity,
+		    uf_is_top 	    = top_lvl,
+		    uf_is_value     = exprIsHNF        expr,
+                    uf_is_conlike   = exprIsConLike    expr,
+		    uf_is_work_free = exprIsWorkFree   expr,
+		    uf_expandable   = exprIsExpandable expr,
+		    uf_guidance     = guidance }
 
 mkUnfolding :: UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding
 -- Calculates unfolding guidance
@@ -163,17 +163,18 @@ mkUnfolding src top_lvl is_bottoming expr
   , not (exprIsTrivial expr)
   = NoUnfolding    -- See Note [Do not inline top-level bottoming functions]
   | otherwise
-  = CoreUnfolding { uf_tmpl   	  = occurAnalyseExpr expr,
-    		    uf_src        = src,
-    		    uf_arity      = arity,
-		    uf_is_top 	  = top_lvl,
-		    uf_is_value   = exprIsHNF        expr,
-                    uf_is_conlike = exprIsConLike    expr,
-		    uf_expandable = exprIsExpandable expr,
-		    uf_is_cheap   = exprIsCheap      expr,
-		    uf_guidance   = guidance }
+  = CoreUnfolding { uf_tmpl   	    = occ_anald_expr,
+    		    uf_src          = src,
+    		    uf_arity        = arity,
+		    uf_is_top 	    = top_lvl,
+		    uf_is_value     = exprIsHNF        expr,
+                    uf_is_conlike   = exprIsConLike    expr,
+		    uf_expandable   = exprIsExpandable expr,
+		    uf_is_work_free = exprIsWorkFree   expr,
+		    uf_guidance     = guidance }
   where
-    (arity, guidance) = calcUnfoldingGuidance expr
+    occ_anald_expr    = occurAnalyseExpr expr
+    (arity, guidance) = calcUnfoldingGuidance occ_anald_expr
 	-- Sometimes during simplification, there's a large let-bound thing	
 	-- which has been substituted, and so is now dead; so 'expr' contains
 	-- two copies of the thing while the occurrence-analysed expression doesn't
@@ -501,80 +502,6 @@ sizeExpr bOMB_OUT_SIZE top_args expr
                                  d2  -- Ignore d1
 \end{code}
 
-Note [Function application discount]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-I noticed that the output of the supercompiler generates a lot of code
-with this form:
-
-"""
-module Inlining where
-
-h1 k = k undefined undefined undefined
-        undefined undefined undefined
-        undefined undefined undefined
-        undefined undefined undefined
-        undefined undefined undefined
-        undefined undefined undefined
-
-a = h1 (\x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> x)
-b = h1 (\_ x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> x)
-c = h1 (\_ _ x _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> x)
-d = h1 (\_ _ _ x _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> x)
-e = h1 (\_ _ _ _ x _ _ _ _ _ _ _ _ _ _ _ _ _ -> x)
-f = h1 (\_ _ _ _ _ x _ _ _ _ _ _ _ _ _ _ _ _ -> x)
-g = h1 (\_ _ _ _ _ _ x _ _ _ _ _ _ _ _ _ _ _ -> x)
-h = h1 (\_ _ _ _ _ _ _ x _ _ _ _ _ _ _ _ _ _ -> x)
-i = h1 (\_ _ _ _ _ _ _ _ x _ _ _ _ _ _ _ _ _ -> x)
-j = h1 (\_ _ _ _ _ _ _ _ _ x _ _ _ _ _ _ _ _ -> x)
-k = h1 (\_ _ _ _ _ _ _ _ _ _ x _ _ _ _ _ _ _ -> x)
-l = h1 (\_ _ _ _ _ _ _ _ _ _ _ x _ _ _ _ _ _ -> x)
-m = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ x _ _ _ _ _ -> x)
-n = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ x _ _ _ _ -> x)
-o = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ _ x _ _ _ -> x)
-p = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ x _ _ -> x)
-q = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ x _ -> x)
-r = h1 (\_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ x -> x)
-"""
-
-With GHC head the applications of h1 are not inlined, which hurts the
-quality of the generated code a bit. I was wondering why h1 wasn't
-getting inlined into each of "a" to "i" - after all, it has a manifest
-lambda argument.
-
-It turns out that the code in CoreUnfold gives a fixed discount of
-opt_UF_FunAppDiscount to a function argument such as "k" if it applied
-to any arguments. This is enough to ensure that h1 is inlined if the number
-of arguments applied to k is below a certain limit, but if many arguments are
-applied to k then the fixed discount can't overcome the size of the
-chain of apps, and h1 is never inlined.
-
-My proposed solution is to change CoreUnfold.funSize so that longer
-chains of arguments being applied to a lambda-bound function give a
-bigger discount. The motivation for this is that we would *generally*
-expect that the lambda at the callsite has enough lambdas such that
-all of the applications within the body can be beta-reduced away. This
-change might lead to over eager inlining in cases like this, though:
-
-{{{
-h1 k = k x y z
-
-{-# NOINLINE g #-}
-g = ...
-
-main = ... h1 (\x -> g x) ...
-}}}
-
-In this case we aren't able to beta-reduce away all of the
-applications in the body of h1 because the lambda at the call site
-only binds 1 argument, not the 3 allowed by the type. I don't expect
-this case to be particularly common, however.
-
-I chose the bonus to be (size - 20) so that application to 1 arg got
-same bonus as the old fixed bonus (i.e. opt_UF_FunAppDiscount, which is 60).
-If you have the bonus being (size - 40) then $fMonad[]_$c>>= with interesting
-2nd arg doesn't inline in cryptarithm2 so we lose some deforestation, and
-overall binary size hardly falls.
 
 \begin{code}
 -- | Finds a nominal size of a string literal.
@@ -615,23 +542,29 @@ funSize top_args fun n_val_args
   where
     some_val_args = n_val_args > 0
 
-        -- See Note [Function application discount]
-    arg_discount | some_val_args && fun `elem` top_args
-    		 = unitBag (fun, opt_UF_FunAppDiscount + (size - 20))
-		 | otherwise = emptyBag
-	-- If the function is an argument and is applied
-	-- to some values, give it an arg-discount
-
-        -- See Note [Function application discount]
-    res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount + (size - 20)
-    		 | otherwise   	 	    = 0
-        -- If the function is partially applied, show a result discount
     size | some_val_args = 10 * (1 + n_val_args)
          | otherwise     = 0
 	-- The 1+ is for the function itself
 	-- Add 1 for each non-trivial arg;
 	-- the allocation cost, as in let(rec)
   
+        --                  DISCOUNTS
+        --  See Note [Function application discounts]
+    arg_discount | some_val_args && one_call fun top_args
+    		 = unitBag (fun, opt_UF_FunAppDiscount)
+		 | otherwise = emptyBag
+	-- If the function is an argument and is applied
+	-- to some values, give it an arg-discount
+
+    res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount
+    		 | otherwise   	 	    = 0
+        -- If the function is partially applied, show a result discount
+
+    one_call _   []                     = False
+    one_call fun (arg:args) | fun==arg  = case idOccInfo arg of
+                                           OneOcc _ one_branch _ -> one_branch
+                                           _                     -> False
+                            | otherwise = one_call fun args
 
 conSize :: DataCon -> Int -> ExprSize
 conSize dc n_val_args
@@ -648,6 +581,21 @@ conSize dc n_val_args
      -- [SDM, 25/5/11]
 \end{code}
 
+Note [Function application discount]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want a discount if the function is applied. A good example is
+monadic combinators with continuation arguments, where inlining is
+quite important.
+
+But we don't want a big discount when a function is called many times
+(see the detailed comments with Trac #6048) because if the function is 
+big it won't be inlined at its many call sites and no benefit results.
+Indeed, we can get exponentially big inlinings this way; that is what
+Trac #6048 is about.
+
+So, we only give a function-application discount when the function appears
+textually once, albeit possibly inside a lambda.
+
 Note [Literal integer size]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Literal integers *can* be big (mkInteger [...coefficients...]), but
@@ -918,11 +866,11 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info
       -- Things with an INLINE pragma may have an unfolding *and* 
       -- be a loop breaker  (maybe the knot is not yet untied)
 	CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top 
-		      , uf_is_cheap = is_cheap, uf_arity = uf_arity
+		      , uf_is_work_free = is_wf, uf_arity = uf_arity
                       , uf_guidance = guidance, uf_expandable = is_exp }
           | active_unfolding -> tryUnfolding dflags id lone_variable 
                                     arg_infos cont_info unf_template is_top 
-                                    is_cheap is_exp uf_arity guidance
+                                    is_wf is_exp uf_arity guidance
           | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
           -> pprTrace "Inactive unfolding:" (ppr id) Nothing
           | otherwise -> Nothing
@@ -935,7 +883,7 @@ tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt
 	     -> Maybe CoreExpr	
 tryUnfolding dflags id lone_variable 
              arg_infos cont_info unf_template is_top 
-             is_cheap is_exp uf_arity guidance
+             is_wf is_exp uf_arity guidance
 			-- uf_arity will typically be equal to (idArity id), 
 			-- but may be less for InlineRules
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
@@ -945,7 +893,7 @@ tryUnfolding dflags id lone_variable
 			text "interesting continuation" <+> ppr cont_info,
 			text "some_benefit" <+> ppr some_benefit,
                         text "is exp:" <+> ppr is_exp,
-                        text "is cheap:" <+> ppr is_cheap,
+                        text "is work-free:" <+> ppr is_wf,
 			text "guidance" <+> ppr guidance,
 			extra_doc,
 			text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"])
@@ -979,7 +927,7 @@ tryUnfolding dflags id lone_variable
     interesting_saturated_call 
       = case cont_info of
           BoringCtxt -> not is_top && uf_arity > 0	  -- Note [Nested functions]
-          CaseCtxt   -> not (lone_variable && is_cheap)   -- Note [Lone variables]
+          CaseCtxt   -> not (lone_variable && is_wf)      -- Note [Lone variables]
           ArgCtxt {} -> uf_arity > 0     		  -- Note [Inlining in ArgCtxt]
           ValAppCtxt -> True			          -- Note [Cast then apply]
 
@@ -993,7 +941,7 @@ tryUnfolding dflags id lone_variable
                enough_args = saturated || (unsat_ok && n_val_args > 0)
 
           UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
-      	     -> ( is_cheap && some_benefit && small_enough
+      	     -> ( is_wf && some_benefit && small_enough
                 , (text "discounted size =" <+> int discounted_size) )
     	     where
     	       discounted_size = size - discount
@@ -1105,7 +1053,7 @@ call is at least CONLIKE.  At least for the cases where we use ArgCtxt
 for the RHS of a 'let', we only profit from the inlining if we get a 
 CONLIKE thing (modulo lets).
 
-Note [Lone variables]	See also Note [Interaction of exprIsCheap and lone variables]
+Note [Lone variables]	See also Note [Interaction of exprIsWorkFree and lone variables]
 ~~~~~~~~~~~~~~~~~~~~~   which appears below
 The "lone-variable" case is important.  I spent ages messing about
 with unsatisfactory varaints, but this is nice.  The idea is that if a
@@ -1152,7 +1100,7 @@ However, watch out:
 
    So the non-inlining of lone_variables should only apply if the
    unfolding is regarded as cheap; because that is when exprIsConApp_maybe
-   looks through the unfolding.  Hence the "&& is_cheap" in the
+   looks through the unfolding.  Hence the "&& is_wf" in the
    InlineRule branch.
 
  * Even a type application or coercion isn't a lone variable.
@@ -1167,7 +1115,7 @@ However, watch out:
    There's no advantage in inlining f here, and perhaps
    a significant disadvantage.  Hence some_val_args in the Stop case
 
-Note [Interaction of exprIsCheap and lone variables]
+Note [Interaction of exprIsWorkFree and lone variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The lone-variable test says "don't inline if a case expression
 scrutines a lone variable whose unfolding is cheap".  It's very 
@@ -1178,9 +1126,9 @@ consider
 to be cheap, and that's good because exprIsConApp_maybe doesn't
 think that expression is a constructor application.
 
-I used to test is_value rather than is_cheap, which was utterly
-wrong, because the above expression responds True to exprIsHNF, 
-which is what sets is_value.
+In the 'not (lone_variable && is_wf)' test, I used to test is_value
+rather than is_wf, which was utterly wrong, because the above
+expression responds True to exprIsHNF, which is what sets is_value.
 
 This kind of thing can occur if you have
 
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 8ec132f993..34046e8159 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -22,7 +22,7 @@ module CoreUtils (
         exprType, coreAltType, coreAltsType,
         exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
         exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
-        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects,
+        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
         exprIsBig, exprIsConLike,
         rhsIsStatic, isCheapApp, isExpandableApp,
 
@@ -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;
@@ -640,6 +632,68 @@ dupAppSize = 8   -- Size of term we are prepared to duplicate
 %*                                                                      *
 %************************************************************************
 
+Note [exprIsWorkFree]
+~~~~~~~~~~~~~~~~~~~~~
+exprIsWorkFree is used when deciding whether to inline something; we
+don't inline it if doing so might duplicate work, by peeling off a
+complete copy of the expression.  Here we do not want even to
+duplicate a primop (Trac #5623):
+   eg   let x = a #+ b in x +# x
+   we do not want to inline/duplicate x
+
+Previously we were a bit more liberal, which led to the primop-duplicating
+problem.  However, being more conservative did lead to a big regression in
+one nofib benchmark, wheel-sieve1.  The situation looks like this:
+
+   let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool
+       noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->
+         case GHC.Prim.<=# x_aRs 2 of _ {
+           GHC.Types.False -> notDivBy ps_adM qs_adN;
+           GHC.Types.True -> lvl_r2Eb }}
+       go = \x. ...(noFactor (I# y))....(go x')...
+
+The function 'noFactor' is heap-allocated and then called.  Turns out
+that 'notDivBy' is strict in its THIRD arg, but that is invisible to
+the caller of noFactor, which therefore cannot do w/w and
+heap-allocates noFactor's argument.  At the moment (May 12) we are just
+going to put up with this, because the previous more aggressive inlining 
+(which treated 'noFactor' as work-free) was duplicating primops, which 
+in turn was making inner loops of array calculations runs slow (#5623)
+
+\begin{code}
+exprIsWorkFree :: CoreExpr -> Bool
+-- See Note [exprIsWorkFree]
+exprIsWorkFree e = go 0 e
+  where    -- n is the number of value arguments
+    go _ (Lit {})                     = True
+    go _ (Type {})                    = True
+    go _ (Coercion {})                = True
+    go n (Cast e _)                   = go n e
+    go n (Case scrut _ _ alts)        = foldl (&&) (exprIsWorkFree scrut) 
+                                              [ go n rhs | (_,_,rhs) <- alts ]
+         -- See Note [Case expressions are work-free]
+    go _ (Let {})                     = False
+    go n (Var v)                      = n==0 || n < idArity v
+    go n (Tick t e) | tickishCounts t = False
+                    | otherwise       = go n e
+    go n (Lam x e)  | isRuntimeVar x = n==0 || go (n-1) e
+                    | otherwise      = go n e
+    go n (App f e)  | isRuntimeArg e = exprIsWorkFree e && go (n+1) f
+                    | otherwise      = go n f
+\end{code}
+
+Note [Case expressions are work-free]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Are case-expressions work-free?  Consider
+    let v = case x of (p,q) -> p
+        go = \y -> ...case v of ...
+Should we inline 'v' at its use site inside the loop?  At the moment
+we do.  I experimented with saying that case are *not* work-free, but
+that increased allocation slightly.  It's a fairly small effect, and at
+the moment we go for the slightly more aggressive version which treats
+(case x of ....) as work-free if the alterantives are.
+
+
 Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]
 ~~~~~~~~~~~~~~~~~~   in CoreUnfold.lhs
 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index d98a4ad734..9504b14ee5 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -419,7 +419,7 @@ instance Outputable Unfolding where
                                    <+> ppr con <+> brackets (pprWithCommas ppr ops)
   ppr (CoreUnfolding { uf_src = src
                      , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
-                     , uf_is_conlike=conlike, uf_is_cheap=cheap
+                     , uf_is_conlike=conlike, uf_is_work_free=wf
       		     , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) 
 	= ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs)
     where
@@ -429,7 +429,7 @@ instance Outputable Unfolding where
                 , ptext (sLit "Arity=")      <> int arity
                 , ptext (sLit "Value=")      <> ppr hnf
                 , ptext (sLit "ConLike=")    <> ppr conlike
-                , ptext (sLit "Cheap=")      <> ppr cheap
+                , ptext (sLit "WorkFree=")   <> ppr wf
                 , ptext (sLit "Expandable=") <> ppr exp
                 , ptext (sLit "Guidance=")   <> ppr g ]
       pp_tmpl = ptext (sLit "Tmpl=") <+> ppr rhs
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/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 060b63d46e..98aec5f167 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -150,7 +150,8 @@ repTopDs group
 hsSigTvBinders :: HsValBinds Name -> [Name]
 -- See Note [Scoped type variables in bindings]
 hsSigTvBinders binds
-  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit tvs _ _))) <- sigs, tv <- tvs]
+  = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
+                     , tv <- hsQTvBndrs qtvs]
   where
     sigs = case binds of
      	     ValBindsIn  _ sigs -> sigs
@@ -214,9 +215,8 @@ repTyClD (L loc (TyFamily { tcdFlavour = flavour,
            do { flav   <- repFamilyFlavour flavour
 	      ; case opt_kind of 
                   Nothing -> repFamilyNoKind flav tc1 bndrs
-                  Just (HsBSig ki _) 
-                    -> do { ki1 <- repKind ki 
-                          ; repFamilyKind flav tc1 bndrs ki1 }
+                  Just ki -> do { ki1 <- repKind ki 
+                                ; repFamilyKind flav tc1 bndrs ki1 }
               }
        ; return $ Just (loc, dec)
        }
@@ -272,15 +272,15 @@ repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
        ; repTySyn tc bndrs opt_tys ty1 }
 
 -------------------------
-mk_extra_tvs :: Located Name -> [LHsTyVarBndr Name] 
-             -> HsTyDefn Name -> DsM [LHsTyVarBndr Name]
+mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name 
+             -> HsTyDefn Name -> DsM (LHsTyVarBndrs Name)
 -- If there is a kind signature it must be of form
 --    k1 -> .. -> kn -> *
 -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
 mk_extra_tvs tc tvs defn
-  | TyData { td_kindSig = Just (HsBSig hs_kind _) } <- defn
+  | TyData { td_kindSig = Just hs_kind } <- defn
   = do { extra_tvs <- go hs_kind
-       ; return (tvs ++ extra_tvs) }
+       ; return (mkHsQTvs (hsQTvBndrs tvs ++ extra_tvs)) }
   | otherwise
   = return tvs
   where
@@ -289,7 +289,7 @@ mk_extra_tvs tc tvs defn
       = do { uniq <- newUnique
            ; let { occ = mkTyVarOccFS (fsLit "t")
                  ; nm = mkInternalName uniq occ loc
-                 ; hs_tv = L loc (KindedTyVar nm (mkHsBSig kind)) }
+                 ; hs_tv = L loc (KindedTyVar nm kind) }
            ; hs_tvs <- go rest
            ; return (hs_tv : hs_tvs) }
 
@@ -340,7 +340,7 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
 	    -- the selector Ids, not to fresh names (Trac #5410)
 	    --
             do { cxt1 <- repContext cxt
-               ; cls_tcon <- repTy (HsTyVar cls)
+               ; cls_tcon <- repTy (HsTyVar (unLoc cls))
                ; cls_tys <- repLTys tys
                ; inst_ty1 <- repTapps cls_tcon cls_tys
                ; binds1 <- rep_binds binds
@@ -350,17 +350,17 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
                ; repInst cxt1 inst_ty1 decls }
        ; return (loc, dec) }
  where
-   Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty)
+   Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
 
 repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
 repFamInstD (FamInstDecl { fid_tycon = tc_name
-                         , fid_pats = HsBSig tys (kv_names, tv_names)
+                         , fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
                          , fid_defn = defn })
   = WARN( not (null kv_names), ppr kv_names )   -- We have not yet dealt with kind 
                                                 -- polymorphism in Template Haskell (sigh)
     do { tc <- lookupLOcc tc_name 		-- See note [Binders and occurrences]  
        ; let loc = getLoc tc_name
-             hs_tvs = [ L loc (UserTyVar n) | n <- tv_names]   -- Yuk
+             hs_tvs = mkHsQTvs (userHsTyVarBndrs loc tv_names)   -- Yuk
        ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
          do { tys1 <- repLTys tys
             ; tys2 <- coreList typeQTyConName tys1
@@ -419,8 +419,9 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
 -------------------------------------------------------
 
 repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
-repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ []
+repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
                        , con_details = details, con_res = ResTyH98 }))
+  | null (hsQTvBndrs con_tvs)
   = do { con1 <- lookupLOcc con 	-- See note [Binders and occurrences] 
        ; repConstr con1 details  }
 repC tvs (L _ (ConDecl { con_name = con
@@ -428,7 +429,7 @@ repC tvs (L _ (ConDecl { con_name = con
                        , con_details = details
                        , con_res = res_ty }))
   = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
-       ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
+       ; let ex_tvs = mkHsQTvs [ tv | tv <- hsQTvBndrs con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
        ; binds <- mapM dupBinder con_tv_subst 
        ; dsExtendMetaEnv (mkNameEnv binds) $     -- Binds some of the con_tvs
          addTyVarBinds ex_tvs $ \ ex_bndrs ->   -- Binds the remaining con_tvs
@@ -552,7 +553,7 @@ rep_ty_sig loc (L _ ty) nm
     rep_ty (HsForAllTy Explicit tvs ctxt ty)
       = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
                                          ; repTyVarBndrWithKind tv name }
-           ; bndrs1 <- mapM rep_in_scope_tv tvs
+           ; bndrs1 <- mapM rep_in_scope_tv (hsQTvBndrs tvs)
            ; bndrs2 <- coreList tyVarBndrTyConName bndrs1
            ; ctxt1  <- repLContext ctxt
            ; ty1    <- repLTy ty
@@ -616,7 +617,7 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin
 -- 			Types
 -------------------------------------------------------
 
-addTyVarBinds :: [LHsTyVarBndr Name]	                       -- the binders to be added
+addTyVarBinds :: LHsTyVarBndrs Name	                       -- the binders to be added
               -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))  -- action in the ext env
               -> DsM (Core (TH.Q a))
 -- gensym a list of type variables and enter them into the meta environment;
@@ -626,14 +627,14 @@ addTyVarBinds :: [LHsTyVarBndr Name]	                       -- the binders to be
 addTyVarBinds tvs m
   = do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
        ; term <- addBinds freshNames $ 
-	    	 do { kbs1 <- mapM mk_tv_bndr (tvs `zip` freshNames)
+	    	 do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
                     ; kbs2 <- coreList tyVarBndrTyConName kbs1
 	    	    ; m kbs2 }
        ; wrapGenSyms freshNames term }
   where
     mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
 
-addTyClTyVarBinds :: [LHsTyVarBndr Name]
+addTyClTyVarBinds :: LHsTyVarBndrs Name
                   -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
                   -> DsM (Core (TH.Q a))
 
@@ -650,7 +651,7 @@ addTyClTyVarBinds tvs m
             -- This makes things work for family declarations
 
        ; term <- addBinds freshNames $ 
-	    	 do { kbs1 <- mapM mk_tv_bndr tvs
+	    	 do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs)
                     ; kbs2 <- coreList tyVarBndrTyConName kbs1
 	    	    ; m kbs2 }
 
@@ -665,7 +666,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
                      -> Core TH.Name -> DsM (Core TH.TyVarBndr)
 repTyVarBndrWithKind (L _ (UserTyVar {})) nm
   = repPlainTV nm
-repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm
+repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
   = repKind ki >>= repKindedTV nm
 
 -- represent a type context
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index c8b1b303b5..c84d84a78c 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -482,6 +482,9 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
 -- ignore other kinds of tick
 schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
 
+schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
+        -- no alts: scrut is guaranteed to diverge
+
 schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
    | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
         -- Convert
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 7e8ceb6695..8d5ad6b4f0 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -275,7 +275,7 @@ cvt_ci_decs doc decs
 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
              -> CvtM ( LHsContext RdrName
                      , Located RdrName
-                     , [LHsTyVarBndr RdrName])
+                     , LHsTyVarBndrs RdrName)
 cvt_tycl_hdr cxt tc tvs
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
@@ -286,12 +286,12 @@ cvt_tycl_hdr cxt tc tvs
 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
                -> CvtM ( LHsContext RdrName
                        , Located RdrName
-                       , HsBndrSig [LHsType RdrName])
+                       , HsWithBndrs [LHsType RdrName])
 cvt_tyinst_hdr cxt tc tys
   = do { cxt' <- cvtContext cxt
        ; tc'  <- tconNameL tc
        ; tys' <- mapM cvtType tys
-       ; return (cxt', tc', mkHsBSig tys') }
+       ; return (cxt', tc', mkHsWithBndrs tys') }
 
 -------------------------------------------------------------------
 --		Partitioning declarations
@@ -348,7 +348,7 @@ cvtConstr (ForallC tvs ctxt con)
   = do	{ tvs'  <- cvtTvs tvs
 	; L loc ctxt' <- cvtContext ctxt
 	; L _ con' <- cvtConstr con
-	; returnL $ con' { con_qvars = tvs' ++ con_qvars con'
+	; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
                          , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
@@ -759,7 +759,7 @@ cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 		       	    ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
 cvtp (ListP ps)        = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
-                            ; return $ SigPatIn p' (mkHsBSig t') }
+                            ; return $ SigPatIn p' (mkHsWithBndrs t') }
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
 
 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
@@ -784,8 +784,8 @@ cvtOpAppP x op y
 -----------------------------------------------------------
 --	Types and type variables
 
-cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
-cvtTvs tvs = mapM cvt_tv tvs
+cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
+cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
 
 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
 cvt_tv (TH.PlainTV nm) 
@@ -794,7 +794,7 @@ cvt_tv (TH.PlainTV nm)
 cvt_tv (TH.KindedTV nm ki) 
   = do { nm' <- tName nm
        ; ki' <- cvtKind ki
-       ; returnL $ KindedTyVar nm' (mkHsBSig ki') }
+       ; returnL $ KindedTyVar nm' ki' }
 
 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
@@ -845,7 +845,7 @@ cvtType ty
              -> do { tvs' <- cvtTvs tvs
                    ; cxt' <- cvtContext cxt
                    ; ty'  <- cvtType ty
-                   ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' 
+                   ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty' 
                    }
 
            SigT ty ki
@@ -875,10 +875,10 @@ cvtKind (ArrowK k1 k2) = do
   k2' <- cvtKind k2
   returnL (HsFunTy k1' k2')
 
-cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName)))
+cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
 cvtMaybeKind Nothing = return Nothing
 cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
-                            ; return (Just (mkHsBSig ki')) }
+                            ; return (Just ki') }
 
 -----------------------------------------------------------
 cvtFixity :: TH.Fixity -> Hs.Fixity
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index c789a9efdc..cf1c2c9a8e 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -428,20 +428,20 @@ data TyClDecl name
   | -- | @type/data family T :: *->*@
     TyFamily {  tcdFlavour :: FamilyFlavour,             -- type or data
                 tcdLName   :: Located name,              -- type constructor
-                tcdTyVars  :: [LHsTyVarBndr name],       -- type variables
-                tcdKindSig :: Maybe (HsBndrSig (LHsKind name))  -- result kind
+                tcdTyVars  :: LHsTyVarBndrs name,        -- type variables
+                tcdKindSig :: Maybe (LHsKind name)       -- result kind
     }
 
 
   | -- | @type/data declaration
     TyDecl { tcdLName  :: Located name            -- ^ Type constructor
-           , tcdTyVars :: [LHsTyVarBndr name]
+           , tcdTyVars :: LHsTyVarBndrs name
            , tcdTyDefn :: HsTyDefn name
            , tcdFVs    :: NameSet }
 
   | ClassDecl { tcdCtxt    :: LHsContext name,          -- ^ Context...
                 tcdLName   :: Located name,             -- ^ Name of the class
-                tcdTyVars  :: [LHsTyVarBndr name],      -- ^ Class type variables
+                tcdTyVars  :: LHsTyVarBndrs name,       -- ^ Class type variables
                 tcdFDs     :: [Located (FunDep name)],  -- ^ Functional deps
                 tcdSigs    :: [LSig name],              -- ^ Methods' signatures
                 tcdMeths   :: LHsBinds name,            -- ^ Default methods
@@ -468,7 +468,7 @@ data HsTyDefn name   -- The payload of a type synonym or data type defn
     TyData { td_ND     :: NewOrData,
              td_ctxt   :: LHsContext name,           -- ^ Context
              td_cType  :: Maybe CType,
-             td_kindSig:: Maybe (HsBndrSig (LHsKind name)),
+             td_kindSig:: Maybe (LHsKind name),
                      -- ^ Optional kind signature.
                      --
                      -- @(Just k)@ for a GADT-style @data@, or @data
@@ -619,18 +619,18 @@ instance OutputableBndr name
 
 pp_vanilla_decl_head :: OutputableBndr name
    => Located name
-   -> [LHsTyVarBndr name]
+   -> LHsTyVarBndrs name
    -> HsContext name
    -> SDoc
 pp_vanilla_decl_head thing tyvars context
- = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), interppSP tyvars]
+ = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
 
 pp_fam_inst_head :: OutputableBndr name
    => Located name
-   -> HsBndrSig [LHsType name]
+   -> HsWithBndrs [LHsType name]
    -> HsContext name
    -> SDoc
-pp_fam_inst_head thing (HsBSig typats _)  context -- explicit type patterns
+pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
    = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing)
           , hsep (map (pprParendHsType.unLoc) typats)]
 
@@ -660,8 +660,8 @@ pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context
        2 (pp_condecls condecls $$ pp_derivings)
   where
     pp_sig = case mb_sig of
-               Nothing              -> empty
-               Just (HsBSig kind _) -> dcolon <+> ppr kind
+               Nothing   -> empty
+               Just kind -> dcolon <+> ppr kind
     pp_derivings = case derivings of
                      Nothing -> empty
                      Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
@@ -715,7 +715,7 @@ data ConDecl name
     , con_explicit  :: HsExplicitFlag
         -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
 
-    , con_qvars     :: [LHsTyVarBndr name]
+    , con_qvars     :: LHsTyVarBndrs name
         -- ^ Type variables.  Depending on 'con_res' this describes the
         -- following entities
         --
@@ -808,8 +808,8 @@ type LFamInstDecl name = Located (FamInstDecl name)
 data FamInstDecl name 
   = FamInstDecl
        { fid_tycon :: Located name
-       , fid_pats  :: HsBndrSig [LHsType name]  -- ^ Type patterns (with bndrs)
-       , fid_defn  :: HsTyDefn name             -- Type or data family instance
+       , fid_pats  :: HsWithBndrs [LHsType name]  -- ^ Type patterns (with kind and type bndrs)
+       , fid_defn  :: HsTyDefn name               -- Type or data family instance
        , fid_fvs   :: NameSet  } 
   deriving( Typeable, Data )
 
@@ -1060,10 +1060,10 @@ data RuleDecl name
 
 data RuleBndr name
   = RuleBndr (Located name)
-  | RuleBndrSig (Located name) (HsBndrSig (LHsType name))
+  | RuleBndrSig (Located name) (HsWithBndrs (LHsType name))
   deriving (Data, Typeable)
 
-collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (LHsType name)]
+collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs (LHsType name)]
 collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
 
 instance OutputableBndr name => Outputable (RuleDecl name) where
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 1a5e206a54..64bda890db 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -131,8 +131,8 @@ data Pat id
                     (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
 
         ------------ Pattern type signatures ---------------
-  | SigPatIn        (LPat id)           -- Pattern with a type signature
-                    (HsBndrSig (LHsType id))
+  | SigPatIn        (LPat id)                   -- Pattern with a type signature
+                    (HsWithBndrs (LHsType id))  -- Signature can bind both kind and type vars
 
   | SigPatOut       (LPat id)           -- Pattern with a type signature
                     Type
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 9a6679a68e..2504ad892e 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -17,7 +17,9 @@ HsTypes: Abstract syntax: user-defined types
 
 module HsTypes (
         HsType(..), LHsType, HsKind, LHsKind,
-        HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr,
+        HsTyVarBndr(..), LHsTyVarBndr, 
+        LHsTyVarBndrs(..),
+        HsWithBndrs(..),
         HsTupleSort(..), HsExplicitFlag(..),
         HsContext, LHsContext,
         HsQuasiQuote(..),
@@ -29,15 +31,14 @@ module HsTypes (
 
         ConDeclField(..), pprConDeclFields,
         
+        mkHsQTvs, hsQTvBndrs,
         mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
-        hsTyVarName, hsTyVarNames, 
+        hsTyVarName, hsTyVarNames, mkHsWithBndrs,
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
-        splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
-        splitHsForAllTy, splitLHsForAllTy,
+        splitLHsInstDeclTy_maybe,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
         splitHsFunType,
         splitHsAppTys, mkHsAppTys, mkHsOpTy,
-        placeHolderBndrs,
 
         -- Printing
         pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
@@ -112,6 +113,17 @@ getBangStrictness _                    = HsNoBang
 
 This is the syntax for types as seen in type signatures.
 
+Note [HsBSig binder lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a binder (or pattern) decoarated with a type or kind, 
+   \ (x :: a -> a). blah
+   forall (a :: k -> *) (b :: k). blah
+Then we use a LHsBndrSig on the binder, so that the
+renamer can decorate it with the variables bound
+by the pattern ('a' in the first example, 'k' in the second),
+assuming that neither of them is in scope already
+See also Note [Kind and type-variable binders] in RnTypes
+
 \begin{code}
 type LHsContext name = Located (HsContext name)
 
@@ -123,29 +135,29 @@ type LHsKind name = Located (HsKind name)
 
 type LHsTyVarBndr name = Located (HsTyVarBndr name)
 
-data HsBndrSig sig 
-  = HsBSig 
-       sig                -- The signature; typically a type
-       ([Name], [Name])   -- The *binding* (kind, type) names of 
-                          -- this signature
-                          -- See Note [HsBSig binder lists]
-                          
+data LHsTyVarBndrs name 
+  = HsQTvs { hsq_kvs :: [Name]                  -- Kind variables
+           , hsq_tvs :: [LHsTyVarBndr name]     -- Type variables
+             -- See Note [HsForAllTy tyvar binders]
+    }
+  deriving( Data, Typeable )
+
+mkHsQTvs :: [LHsTyVarBndr name] -> LHsTyVarBndrs name
+mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs }
+
+hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
+hsQTvBndrs = hsq_tvs
+
+data HsWithBndrs thing
+  = HsWB { hswb_cts :: thing           -- Main payload (type or list of types)
+         , hswb_kvs :: [Name]         -- Kind vars
+         , hswb_tvs :: [Name]        -- Type vars
+    }                  
   deriving (Data, Typeable)
 
--- Note [HsBSig binder lists]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Consider a binder (or pattern) decoarated with a type or kind, 
---    \ (x :: a -> a). blah
---    forall (a :: k -> *) (b :: k). blah
--- Then we use a LHsBndrSig on the binder, so that the
--- renamer can decorate it with the variables bound
--- by the pattern ('a' in the first example, 'k' in the second),
--- assuming that neither of them is in scope already
--- See also Note [Kind and type-variable binders] in RnTypes
-
-placeHolderBndrs :: [Name]
--- Used for the NameSet in FunBind and PatBind prior to the renamer
-placeHolderBndrs = panic "placeHolderBndrs"
+mkHsWithBndrs :: thing -> HsWithBndrs thing
+mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs"
+                                     , hswb_tvs = panic "mkHsTyWithBndrs:tvs" }
 
 data HsTyVarBndr name
   = UserTyVar           -- No explicit kinding
@@ -153,17 +165,18 @@ data HsTyVarBndr name
 
   | KindedTyVar
          name
-         (HsBndrSig (LHsKind name))   -- The user-supplied kind signature
+         (LHsKind name)   -- The user-supplied kind signature
       --  *** NOTA BENE *** A "monotype" in a pragma can have
       -- for-alls in it, (mostly to do with dictionaries).  These
       -- must be explicitly Kinded.
   deriving (Data, Typeable)
 
+
 data HsType name
   = HsForAllTy  HsExplicitFlag          -- Renamer leaves this flag unchanged, to record the way
                                         -- the user wrote it originally, so that the printer can
                                         -- print it as the user wrote it
-                [LHsTyVarBndr name]     -- See Note [HsForAllTy tyvar binders]
+                (LHsTyVarBndrs name) 
                 (LHsContext name)
                 (LHsType name)
 
@@ -252,11 +265,11 @@ After renaming
   * Implicit => the *type* variables free in the type
     Explicit => the variables the user wrote (renamed)
 
-Note that in neither case do we inclde the kind variables.
-In the explicit case, the [HsTyVarBndr] can bring kind variables
-into scope:    f :: forall (a::k->*) (b::k). a b -> Int
-but we do not record them explicitly, similar to the case
-for the type variables in a pattern type signature.
+The kind variables bound in the hsq_kvs field come both
+  a) from the kind signatures on the kind vars (eg k1)
+  b) from the scope of the forall (eg k2)
+Example:   f :: forall (a::k1) b. T a (b::k2)
+
 
 Note [Unit tuples]
 ~~~~~~~~~~~~~~~~~~
@@ -357,19 +370,19 @@ data ConDeclField name  -- Record fields have Haddoc docs on them
 
 mkImplicitHsForAllTy ::                        LHsContext name -> LHsType name -> HsType name
 mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
-mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit [] ctxt ty
+mkImplicitHsForAllTy     ctxt ty = mkHsForAllTy Implicit []  ctxt ty
 mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty
 
 mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name
 -- Smart constructor for HsForAllTy
 mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty
-mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty
+mkHsForAllTy exp tvs ctxt     ty = HsForAllTy exp (mkHsQTvs tvs) ctxt ty
 
 -- mk_forall_ty makes a pure for-all type (no context)
 mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name
-mk_forall_ty exp  tvs  (L _ (HsParTy ty))                   = mk_forall_ty exp tvs ty
-mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty
-mk_forall_ty exp  tvs  ty                                   = HsForAllTy exp tvs (noLoc []) ty
+mk_forall_ty exp  tvs  (L _ (HsParTy ty))                    = mk_forall_ty exp tvs ty
+mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 qtvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ hsq_tvs qtvs2) ctxt ty
+mk_forall_ty exp  tvs  ty                                    = HsForAllTy exp (mkHsQTvs tvs) (noLoc []) ty
         -- Even if tvs is empty, we still make a HsForAll!
         -- In the Implicit case, this signals the place to do implicit quantification
         -- In the Explicit case, it prevents implicit quantification    
@@ -396,14 +409,14 @@ hsLTyVarName = hsTyVarName . unLoc
 hsTyVarNames :: [HsTyVarBndr name] -> [name]
 hsTyVarNames tvs = map hsTyVarName tvs
 
-hsLTyVarNames :: [LHsTyVarBndr name] -> [name]
-hsLTyVarNames = map hsLTyVarName
+hsLTyVarNames :: LHsTyVarBndrs name -> [name]
+hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs)
 
 hsLTyVarLocName :: LHsTyVarBndr name -> Located name
 hsLTyVarLocName = fmap hsTyVarName
 
-hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name]
-hsLTyVarLocNames = map hsLTyVarLocName
+hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name]
+hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
 \end{code}
 
 
@@ -421,31 +434,23 @@ mkHsAppTys fun_ty (arg_ty:arg_tys)
        -- Add noLocs for inner nodes of the application; 
        -- they are never used 
 
-splitHsInstDeclTy_maybe :: HsType name 
-                        -> Maybe ([LHsTyVarBndr name], HsContext name, name, [LHsType name])
-splitHsInstDeclTy_maybe ty
-  = fmap (\(tvs, cxt, L _ n, tys) -> (tvs, cxt, n, tys)) $ splitLHsInstDeclTy_maybe (noLoc ty)
-
 splitLHsInstDeclTy_maybe
     :: LHsType name 
-    -> Maybe ([LHsTyVarBndr name], HsContext name, Located name, [LHsType name])
+    -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name])
         -- Split up an instance decl type, returning the pieces
 splitLHsInstDeclTy_maybe inst_ty = do
     let (tvs, cxt, ty) = splitLHsForAllTy inst_ty
     (cls, tys) <- splitLHsClassTy_maybe ty
     return (tvs, cxt, cls, tys)
 
-splitHsForAllTy :: HsType name -> ([LHsTyVarBndr name], HsContext name, HsType name)
-splitHsForAllTy ty = case splitLHsForAllTy (noLoc ty) of (tvs, cxt, L _ ty) -> (tvs, cxt, ty)
-
 splitLHsForAllTy
     :: LHsType name 
-    -> ([LHsTyVarBndr name], HsContext name, LHsType name)
+    -> (LHsTyVarBndrs name, HsContext name, LHsType name)
 splitLHsForAllTy poly_ty
   = case unLoc poly_ty of
         HsParTy ty              -> splitLHsForAllTy ty
         HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
-        _                       -> ([], [], poly_ty)
+        _                       -> (mkHsQTvs [], [], poly_ty)
         -- The type vars should have been computed by now, even if they were implicit
 
 splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
@@ -494,22 +499,25 @@ instance (OutputableBndr name) => Outputable (HsType name) where
 instance Outputable HsTyLit where
     ppr = ppr_tylit
 
-instance (Outputable sig) => Outputable (HsBndrSig sig) where
-    ppr (HsBSig ty _) = ppr ty
+instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where
+    ppr qtvs = interppSP (hsQTvBndrs qtvs)
 
 instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name)        = ppr name
     ppr (KindedTyVar name kind) = parens $ hsep [ppr name, dcolon, ppr kind]
 
-pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] ->  LHsContext name -> SDoc
-pprHsForAll exp tvs cxt 
+instance (Outputable thing) => Outputable (HsWithBndrs thing) where
+    ppr (HsWB { hswb_cts = ty }) = ppr ty
+
+pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name ->  LHsContext name -> SDoc
+pprHsForAll exp qtvs cxt 
   | show_forall = forall_part <+> pprHsContext (unLoc cxt)
   | otherwise   = pprHsContext (unLoc cxt)
   where
     show_forall =  opt_PprStyle_Debug
-                || (not (null tvs) && is_explicit)
+                || (not (null (hsQTvBndrs qtvs)) && is_explicit)
     is_explicit = case exp of {Explicit -> True; Implicit -> False}
-    forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot
+    forall_part = ptext (sLit "forall") <+> ppr qtvs <> dot
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
 pprHsContext []         = empty
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 8ac04761fe..32fe487609 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -33,7 +33,7 @@ module HsUtils(
 
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
-  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, mkHsBSig, 
+  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, 
 
   -- Bindings
   mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
@@ -265,9 +265,6 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
 mkHsString :: String -> HsLit
 mkHsString s = HsString (mkFastString s)
 
-mkHsBSig :: a -> HsBndrSig a
-mkHsBSig x = HsBSig x (placeHolderBndrs, placeHolderBndrs)
-
 -------------
 userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
 -- Caller sets location
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index a497dedcda..c26efb2597 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -38,6 +38,7 @@ module DynFlags (
         GhcMode(..), isOneShot,
         GhcLink(..), isNoLink,
         PackageFlag(..),
+        PkgConfRef(..),
         Option(..), showOpt,
         DynLibLoader(..),
         fFlags, fWarningFlags, fLangFlags, xFlags,
@@ -275,7 +276,6 @@ data DynFlag
    | Opt_ForceRecomp
    | Opt_ExcessPrecision
    | Opt_EagerBlackHoling
-   | Opt_ReadUserPackageConf
    | Opt_NoHsMain
    | Opt_SplitObjs
    | Opt_StgStats
@@ -548,8 +548,8 @@ data DynFlags = DynFlags {
   depSuffixes           :: [String],
 
   --  Package flags
-  extraPkgConfs         :: [FilePath],
-        -- ^ The @-package-conf@ flags given on the command line, in the order
+  extraPkgConfs         :: [PkgConfRef] -> [PkgConfRef],
+        -- ^ The @-package-db@ flags given on the command line, in the order
         -- they appeared.
 
   packageFlags          :: [PackageFlag],
@@ -923,7 +923,7 @@ defaultDynFlags mySettings =
 
         hpcDir                  = ".hpc",
 
-        extraPkgConfs           = [],
+        extraPkgConfs           = id,
         packageFlags            = [],
         pkgDatabase             = Nothing,
         pkgState                = panic "no package state yet: call GHC.setSessionDynFlags",
@@ -1340,7 +1340,7 @@ parseDynamicFlagsCmdLine :: Monad m =>
 parseDynamicFlagsCmdLine dflags args = parseDynamicFlags dflags args True
 
 -- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags
--- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-conf).
+-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).
 -- Used to parse flags set in a modules pragma.
 parseDynamicFilePragma :: Monad m =>
                      DynFlags -> [Located String]
@@ -1755,8 +1755,13 @@ dynamic_flags = [
 package_flags :: [Flag (CmdLineP DynFlags)]
 package_flags = [
         ------- Packages ----------------------------------------------------
-    Flag "package-conf"          (HasArg extraPkgConf_)
-  , Flag "no-user-package-conf"  (NoArg (unSetDynFlag Opt_ReadUserPackageConf))
+    Flag "package-db"            (HasArg (addPkgConfRef . PkgConfFile))
+  , Flag "clear-package-db"      (NoArg clearPkgConf)
+  , Flag "no-global-package-db"  (NoArg removeGlobalPkgConf)
+  , Flag "no-user-package-db"    (NoArg removeUserPkgConf)
+  , Flag "global-package-db"     (NoArg (addPkgConfRef GlobalPkgConf))
+  , Flag "user-package-db"       (NoArg (addPkgConfRef UserPkgConf))
+
   , Flag "package-name"          (hasArg setPackageName)
   , Flag "package-id"            (HasArg exposePackageId)
   , Flag "package"               (HasArg exposePackage)
@@ -2066,7 +2071,6 @@ xFlags = [
 defaultFlags :: [DynFlag]
 defaultFlags
   = [ Opt_AutoLinkPackages,
-      Opt_ReadUserPackageConf,
 
       Opt_SharedImplib,
 
@@ -2404,8 +2408,28 @@ setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })
 addCmdlineHCInclude :: String -> DynP ()
 addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes =  a : cmdlineHcIncludes s})
 
-extraPkgConf_ :: FilePath -> DynP ()
-extraPkgConf_  p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s })
+data PkgConfRef
+  = GlobalPkgConf
+  | UserPkgConf
+  | PkgConfFile FilePath
+
+addPkgConfRef :: PkgConfRef -> DynP ()
+addPkgConfRef p = upd $ \s -> s { extraPkgConfs = (p:) . extraPkgConfs s }
+
+removeUserPkgConf :: DynP ()
+removeUserPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotUser . extraPkgConfs s }
+  where
+    isNotUser UserPkgConf = False
+    isNotUser _ = True
+
+removeGlobalPkgConf :: DynP ()
+removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extraPkgConfs s }
+  where
+    isNotGlobal GlobalPkgConf = False
+    isNotGlobal _ = True
+
+clearPkgConf :: DynP ()
+clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
 
 exposePackage, exposePackageId, hidePackage, ignorePackage,
         trustPackage, distrustPackage :: String -> DynP ()
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index b975a20fd1..4a54c89545 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1403,7 +1403,7 @@ IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver
 --
 -- We return Nothing to indicate an empty statement (or comment only), not a
 -- parse error.
-hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue]))
+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv))
 hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
 
 -- | Compile a stmt all the way to an HValue, but don't run it
@@ -1414,7 +1414,7 @@ hscStmtWithLocation :: HscEnv
                     -> String -- ^ The statement
                     -> String -- ^ The source
                     -> Int    -- ^ Starting line
-                    -> IO (Maybe ([Id], IO [HValue]))
+                    -> IO (Maybe ([Id], IO [HValue], FixityEnv))
 hscStmtWithLocation hsc_env0 stmt source linenumber =
  runInteractiveHsc hsc_env0 $ do
     hsc_env <- getHscEnv
@@ -1431,7 +1431,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
             -- Rename and typecheck it
             -- Here we lift the stmt into the IO monad, see Note
             -- [Interactively-bound Ids in GHCi] in TcRnDriver
-            (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt
+            (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt
 
             -- Desugar it
             ds_expr <- ioMsgMaybe $
@@ -1443,7 +1443,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
             hval    <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
             let hval_io = unsafeCoerce# hval :: IO [HValue]
 
-            return $ Just (ids, hval_io)
+            return $ Just (ids, hval_io, fix_env)
 
 -- | Compile a decls
 hscDecls :: HscEnv
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 82712e2741..1c8276db33 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -942,6 +942,9 @@ data InteractiveContext
              -- time we update the context, we just take the results
              -- from the instance code that already does that.
 
+         ic_fix_env :: FixityEnv,
+            -- ^ Fixities declared in let statements
+
 #ifdef GHCI
           ic_resume :: [Resume],
              -- ^ The stack of breakpoint contexts
@@ -983,6 +986,7 @@ emptyInteractiveContext dflags
                          ic_tythings   = [],
                          ic_sys_vars   = [],
                          ic_instances  = ([],[]),
+                         ic_fix_env    = emptyNameEnv,
 #ifdef GHCI
                          ic_resume     = [],
 #endif
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index a666220a6e..42147dce94 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -176,6 +176,12 @@ findEnclosingDecls hsc_env inf =
        mb = getModBreaks hmi
    in modBreaks_decls mb ! breakInfo_number inf
 
+-- | Update fixity environment in the current interactive context.
+updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
+updateFixityEnv fix_env = do
+  hsc_env <- getSession
+  let ic = hsc_IC hsc_env
+  setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
 
 -- | Run a statement in the current interactive context.  Statement
 -- may bind multple values.
@@ -206,7 +212,9 @@ runStmtWithLocation source linenumber expr step =
       -- empty statement / comment
       Nothing -> return (RunOk [])
 
-      Just (tyThings, hval) -> do
+      Just (tyThings, hval, fix_env) -> do
+        updateFixityEnv fix_env
+
         status <-
           withVirtualCWD $
             withBreakAction (isStep step) idflags' breakMVar statusMVar $ do
@@ -947,7 +955,8 @@ typeKind normalise str = withSession $ \hsc_env -> do
 
 compileExpr :: GhcMonad m => String -> m HValue
 compileExpr expr = withSession $ \hsc_env -> do
-  Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
+  Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
+  updateFixityEnv fix_env
   hvals <- liftIO hval
   case (ids,hvals) of
     ([_],[hv]) -> return hv
@@ -971,9 +980,11 @@ dynCompileExpr expr = do
                      }
     setContext (IIDecl importDecl : iis)
     let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
-    Just (ids, hvals) <- withSession $ \hsc_env ->
+    Just (ids, hvals, fix_env) <- withSession $ \hsc_env ->
                            liftIO $ hscStmt hsc_env stmt
     setContext iis
+    updateFixityEnv fix_env
+
     vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic])
     case (ids,vals) of
         (_:[], v:[]) -> return v
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index aa5a432762..cdda96193c 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -152,10 +152,10 @@ getPackageDetails :: PackageState -> PackageId -> PackageConfig
 getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdMap ps) pid)
 
 -- ----------------------------------------------------------------------------
--- Loading the package config files and building up the package state
+-- Loading the package db files and building up the package state
 
 -- | Call this after 'DynFlags.parseDynFlags'.  It reads the package
--- configuration files, and sets up various internal tables of package
+-- database files, and sets up various internal tables of package
 -- information, according to the package-related flags on the
 -- command-line (@-package@, @-hide-package@ etc.)
 --
@@ -184,46 +184,37 @@ initPackages dflags = do
 
 readPackageConfigs :: DynFlags -> IO [PackageConfig]
 readPackageConfigs dflags = do
-   e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
-   system_pkgconfs <- getSystemPackageConfigs dflags
-
-   let pkgconfs = case e_pkg_path of
-                    Left _   -> system_pkgconfs
-                    Right path
-                     | last cs == "" -> init cs ++ system_pkgconfs
-                     | otherwise     -> cs
-                     where cs = parseSearchPath path
-                     -- if the path ends in a separator (eg. "/foo/bar:")
-                     -- the we tack on the system paths.
-
-   pkgs <- mapM (readPackageConfig dflags)
-                (pkgconfs ++ reverse (extraPkgConfs dflags))
-                -- later packages shadow earlier ones.  extraPkgConfs
-                -- is in the opposite order to the flags on the
-                -- command line.
-
-   return (concat pkgs)
-
-
-getSystemPackageConfigs :: DynFlags -> IO [FilePath]
-getSystemPackageConfigs dflags = do
-   -- System one always comes first
-   let system_pkgconf = systemPackageConfig dflags
-
-   -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
-   -- unless the -no-user-package-conf flag was given.
-   user_pkgconf <- do
-      if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do
-      appdir <- getAppUserDataDirectory "ghc"
-      let
-         dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
-         pkgconf = dir </> "package.conf.d"
-      --
-      exist <- doesDirectoryExist pkgconf
-      if exist then return [pkgconf] else return []
-    `catchIO` (\_ -> return [])
-
-   return (system_pkgconf : user_pkgconf)
+  let system_conf_refs = [UserPkgConf, GlobalPkgConf]
+
+  e_pkg_path <- tryIO (getEnv "GHC_PACKAGE_PATH")
+  let base_conf_refs = case e_pkg_path of
+        Left _ -> system_conf_refs
+        Right path
+         | null (last cs)
+         -> map PkgConfFile (init cs) ++ system_conf_refs
+         | otherwise
+         -> map PkgConfFile cs
+         where cs = parseSearchPath path
+         -- if the path ends in a separator (eg. "/foo/bar:")
+         -- then we tack on the system paths.
+
+  let conf_refs = reverse (extraPkgConfs dflags base_conf_refs)
+  -- later packages shadow earlier ones.  extraPkgConfs
+  -- is in the opposite order to the flags on the
+  -- command line.
+  confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
+
+  liftM concat $ mapM (readPackageConfig dflags) confs
+
+resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
+resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
+resolvePackageConfig _ UserPkgConf = handleIO (\_ -> return Nothing) $ do
+  appdir <- getAppUserDataDirectory "ghc"
+  let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
+      pkgconf = dir </> "package.conf.d"
+  exist <- doesDirectoryExist pkgconf
+  return $ if exist then Just pkgconf else Nothing
+resolvePackageConfig _ (PkgConfFile name) = return $ Just name
 
 readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
 readPackageConfig dflags conf_file = do
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 378a25c8e1..e40f7b2f11 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -766,13 +766,17 @@ pop_and act span buf len = do _ <- popLexState
 nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool
 nextCharIs buf p = not (atEnd buf) && p (currentChar buf)
 
+{-# INLINE nextCharIsNot #-}
+nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool
+nextCharIsNot buf p = not (nextCharIs buf p)
+
 notFollowedBy :: Char -> AlexAccPred Int
 notFollowedBy char _ _ _ (AI _ buf)
-  = nextCharIs buf (/=char)
+  = nextCharIsNot buf (== char)
 
 notFollowedBySymbol :: AlexAccPred Int
 notFollowedBySymbol _ _ _ (AI _ buf)
-  = nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
+  = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~")
 
 -- We must reject doc comments as being ordinary comments everywhere.
 -- In some cases the doc comment will be selected as the lexeme due to
@@ -782,13 +786,16 @@ notFollowedBySymbol _ _ _ (AI _ buf)
 isNormalComment :: AlexAccPred Int
 isNormalComment bits _ _ (AI _ buf)
   | haddockEnabled bits = notFollowedByDocOrPragma
-  | otherwise           = nextCharIs buf (/='#')
+  | otherwise           = nextCharIsNot buf (== '#')
   where
     notFollowedByDocOrPragma
-       = not $ spaceAndP buf (`nextCharIs` (`elem` "|^*$#"))
+       = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#"))
 
-spaceAndP :: StringBuffer -> (StringBuffer -> Bool) -> Bool
-spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf))
+afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool
+afterOptionalSpace buf p
+    = if nextCharIs buf (== ' ')
+      then p (snd (nextChar buf))
+      else p buf
 
 atEOL :: AlexAccPred Int
 atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n'
@@ -2341,7 +2348,7 @@ dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToStr
 
 known_pragma :: Map String Action -> AlexAccPred Int
 known_pragma prags _ _ len (AI _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags)
-                                          && (nextCharIs buf (\c -> not (isAlphaNum c || c == '_')))
+                                          && (nextCharIsNot buf (\c -> isAlphaNum c || c == '_'))
 
 clean_pragma :: String -> String
 clean_pragma prag = canon_ws (map toLower (unprefix prag))
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index a9cb1d34b7..759d5449f9 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -728,9 +728,9 @@ data_or_newtype :: { Located NewOrData }
         : 'data'        { L1 DataType }
         | 'newtype'     { L1 NewType }
 
-opt_kind_sig :: { Located (Maybe (HsBndrSig (LHsKind RdrName))) }
+opt_kind_sig :: { Located (Maybe (LHsKind RdrName)) }
         :                               { noLoc Nothing }
-        | '::' kind                     { LL (Just (mkHsBSig $2)) }
+        | '::' kind                     { LL (Just $2) }
 
 -- tycl_hdr parses the header of a class or data type decl,
 -- which takes the form
@@ -877,7 +877,7 @@ rule_var_list :: { [RuleBndr RdrName] }
 
 rule_var :: { RuleBndr RdrName }
         : varid                                 { RuleBndr $1 }
-        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (mkHsBSig $4) }
+        | '(' varid '::' ctype ')'              { RuleBndrSig $2 (mkHsWithBndrs $4) }
 
 -----------------------------------------------------------------------------
 -- Warnings and deprecations (c.f. rules)
@@ -1113,7 +1113,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] }
 
 tv_bndr :: { LHsTyVarBndr RdrName }
         : tyvar                         { L1 (UserTyVar (unLoc $1)) }
-        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) (mkHsBSig $4)) }
+        | '(' tyvar '::' kind ')'       { LL (KindedTyVar (unLoc $2) $4) }
 
 fds :: { Located [Located (FunDep RdrName)] }
         : {- empty -}                   { noLoc [] }
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index eee8831065..0382fcae7d 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -128,14 +128,14 @@ tdefs	:: { [TyClDecl RdrName] }
 tdef	:: { TyClDecl RdrName }
 	: '%data' q_tc_name tv_bndrs '=' '{' cons '}' ';'
 	{ TyDecl { tcdLName = noLoc (ifaceExtRdrName $2)
-                 , tcdTyVars = map toHsTvBndr $3
+                 , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
                  , tcdTyDefn = TyData { td_ND = DataType, td_ctxt = noLoc [] 
      	                              , td_kindSig = Nothing
                                       , td_cons = $6, td_derivs = Nothing } } }
 	| '%newtype' q_tc_name tv_bndrs trep ';'
 	{ let tc_rdr = ifaceExtRdrName $2 in
           TyDecl { tcdLName = noLoc tc_rdr
-		 , tcdTyVars = map toHsTvBndr $3
+	         , tcdTyVars = mkHsQTvs (map toHsTvBndr $3)
                  , tcdTyDefn = TyData { td_ND = NewType, td_ctxt = noLoc []
 		                      , td_kindSig = Nothing
                                       , td_cons = $4 (rdrNameOcc tc_rdr), td_derivs = Nothing } } }
@@ -377,16 +377,16 @@ ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName
 toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOccFS tv)) bsig
                   where
-                    bsig = mkHsBSig (toHsKind k)
+                    bsig = toHsKind k
 
 ifaceExtRdrName :: Name -> RdrName
 ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name)
 ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other)
 
 add_forall tv (L _ (HsForAllTy exp tvs cxt t))
-  = noLoc $ HsForAllTy exp (tv:tvs) cxt t
+  = noLoc $ HsForAllTy exp (mkHsQTvs (tv : hsQTvBndrs tvs)) cxt t
 add_forall tv t
-  = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t
+  = noLoc $ HsForAllTy Explicit (mkHsQTvs [tv]) (noLoc []) t
   
 happyError :: P a 
 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 95b65de192..350aedb6f0 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -122,7 +122,7 @@ mkTyData :: SrcSpan
          -> NewOrData
          -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-         -> Maybe (HsBndrSig (LHsKind RdrName))
+         -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LTyClDecl RdrName)
@@ -138,20 +138,20 @@ mkFamInstData :: SrcSpan
          -> NewOrData
          -> Maybe CType
          -> Located (Maybe (LHsContext RdrName), LHsType RdrName)
-         -> Maybe (HsBndrSig (LHsKind RdrName))
+         -> Maybe (LHsKind RdrName)
          -> [LConDecl RdrName]
          -> Maybe [LHsType RdrName]
          -> P (LFamInstDecl RdrName)
 mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
+       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
                                     , fid_defn = defn, fid_fvs = placeHolderNames })) }
 
 mkDataDefn :: NewOrData
            -> Maybe CType
            -> Maybe (LHsContext RdrName)
-           -> Maybe (HsBndrSig (LHsKind RdrName))
+           -> Maybe (LHsKind RdrName)
            -> [LConDecl RdrName]
            -> Maybe [LHsType RdrName]
            -> P (HsTyDefn RdrName)
@@ -181,14 +181,14 @@ mkFamInstSynonym :: SrcSpan
             -> P (LFamInstDecl RdrName)
 mkFamInstSynonym loc lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
-       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsBSig tparams
+       ; return (L loc (FamInstDecl { fid_tycon = tc, fid_pats = mkHsWithBndrs tparams
                                     , fid_defn = TySynonym { td_synRhs = rhs }
                                     , fid_fvs = placeHolderNames })) }
 
 mkTyFamily :: SrcSpan
            -> FamilyFlavour
            -> LHsType RdrName   -- LHS
-           -> Maybe (HsBndrSig (LHsKind RdrName)) -- Optional kind signature
+           -> Maybe (LHsKind RdrName) -- Optional kind signature
            -> P (LTyClDecl RdrName)
 mkTyFamily loc flavour lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
@@ -367,7 +367,7 @@ mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty
        ; return (L loc (ConDecl { con_old_rec  = True
                                 , con_name     = data_con
                                 , con_explicit = Implicit
-                                , con_qvars    = []
+                                , con_qvars    = mkHsQTvs []
                                 , con_cxt      = noLoc []
                                 , con_details  = RecCon flds
                                 , con_res      = ResTyGADT res_ty
@@ -381,7 +381,7 @@ mkSimpleConDecl name qvars cxt details
   = ConDecl { con_old_rec  = False
             , con_name     = name
             , con_explicit = Explicit
-            , con_qvars    = qvars
+            , con_qvars    = mkHsQTvs qvars
             , con_cxt      = cxt
             , con_details  = details
             , con_res      = ResTyH98
@@ -444,17 +444,18 @@ we can bring x,y into scope.  So:
    * For RecCon we do not
 
 \begin{code}
-checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
+checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P (LHsTyVarBndrs RdrName)
 -- Check whether the given list of type parameters are all type variables
 -- (possibly with a kind signature).  If the second argument is `False',
 -- only type variables are allowed and we raise an error on encountering a
 -- non-variable; otherwise, we allow non-variable arguments and return the
 -- entire list of parameters.
-checkTyVars tycl_hdr tparms = mapM chk tparms
+checkTyVars tycl_hdr tparms = do { tvs <- mapM chk tparms
+                                 ; return (mkHsQTvs tvs) }
   where
         -- Check that the name space is correct!
     chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
-        | isRdrTyVar tv    = return (L l (KindedTyVar tv (mkHsBSig k)))
+        | isRdrTyVar tv    = return (L l (KindedTyVar tv k))
     chk (L l (HsTyVar tv))
         | isRdrTyVar tv    = return (L l (UserTyVar tv))
     chk t@(L l _)
@@ -579,7 +580,7 @@ checkAPat dynflags loc e0 = case e0 of
                             let t' = case t of
                                        L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
                                        other -> other
-                            return (SigPatIn e (mkHsBSig t'))
+                            return (SigPatIn e (mkHsWithBndrs t'))
 
    -- n+k patterns
    OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index a8f882a48d..79ccb2179a 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -539,7 +539,7 @@ mkSigTvFn sigs
   = \n -> lookupNameEnv env n `orElse` []
   where
     env :: NameEnv [Name]
-    env = mkNameEnv [ (name, map hsLTyVarName ltvs)
+    env = mkNameEnv [ (name, hsLTyVarNames ltvs)
 		    | L _ (TypeSig names
 			           (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs
                     , (L _ name) <- names]
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 9cb04ff47f..b1f393baaf 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -36,7 +36,7 @@ module RnEnv (
 	bindLocatedLocalsFV, bindLocatedLocalsRn,
 	extendTyVarEnvFVRn,
 
-	checkDupRdrNames, checkDupAndShadowedRdrNames,
+	checkDupRdrNames, checkShadowedRdrNames,
         checkDupNames, checkDupAndShadowedNames, 
 	addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
 	warnUnusedMatches,
@@ -1185,7 +1185,8 @@ bindLocatedLocalsRn :: [Located RdrName]
 	    	    -> ([Name] -> RnM a)
 	    	    -> RnM a
 bindLocatedLocalsRn rdr_names_w_loc enclosed_scope
-  = do { checkDupAndShadowedRdrNames rdr_names_w_loc
+  = do { checkDupRdrNames rdr_names_w_loc
+       ; checkShadowedRdrNames rdr_names_w_loc
 
 	-- Make fresh Names and extend the environment
        ; names <- newLocalBndrsRn rdr_names_w_loc
@@ -1243,11 +1244,10 @@ checkDupNames names
 		-- See Note [Binders in Template Haskell] in Convert
 
 ---------------------
-checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM ()
-checkDupAndShadowedRdrNames loc_rdr_names
-  = do	{ checkDupRdrNames loc_rdr_names
-	; envs <- getRdrEnvs
-	; checkShadowedOccs envs loc_occs }
+checkShadowedRdrNames :: [Located RdrName] -> RnM ()
+checkShadowedRdrNames loc_rdr_names
+  = do { envs <- getRdrEnvs
+       ; checkShadowedOccs envs loc_occs }
   where
     loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names]
 
@@ -1645,8 +1645,10 @@ data HsDocContext
   | SpliceTypeCtx (LHsType RdrName)
   | ClassInstanceCtx
   | VectDeclCtx (Located RdrName)
+  | GenericCtx SDoc   -- Maybe we want to use this more!
 
 docOfHsDocContext :: HsDocContext -> SDoc
+docOfHsDocContext (GenericCtx doc) = doc
 docOfHsDocContext (TypeSigCtx doc) = text "In the type signature for" <+> doc
 docOfHsDocContext PatCtx = text "In a pattern type-signature"
 docOfHsDocContext SpecInstSigCtx = text "In a SPECIALISE instance pragma"
@@ -1666,5 +1668,4 @@ docOfHsDocContext GHCiCtx = ptext (sLit "In GHCi input")
 docOfHsDocContext (SpliceTypeCtx hs_ty) = ptext (sLit "In the spliced type") <+> ppr hs_ty
 docOfHsDocContext ClassInstanceCtx = ptext (sLit "TcSplice.reifyInstances")
 docOfHsDocContext (VectDeclCtx tycon) = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
-
 \end{code}
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index d0302a19a2..3e3c2b66d2 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -162,9 +162,9 @@ matchNameMaker ctxt = LamMk report_unused
                       StmtCtxt GhciStmt -> False
                       _                 -> True
 
-rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name))
+rnHsSigCps :: HsWithBndrs (LHsType RdrName) -> CpsRn (HsWithBndrs (LHsType Name))
 rnHsSigCps sig 
-  = CpsRn (rnHsBndrSig True PatCtx sig)
+  = CpsRn (rnHsBndrSig PatCtx sig)
 
 newPatName :: NameMaker -> Located RdrName -> CpsRn Name
 newPatName (LamMk report_unused) rdr_name
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 8c338c810a..9509b0a4b2 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -43,7 +43,6 @@ import Outputable
 import Bag
 import BasicTypes       ( RuleName )
 import FastString
-import Util		( filterOut )
 import SrcLoc
 import DynFlags
 import HscTypes		( HscEnv, hsc_dflags )
@@ -485,7 +484,9 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds
 	     --     to remove the context).
 
 rnFamInstDecl :: Maybe (Name, [Name]) -> FamInstDecl RdrName -> RnM (FamInstDecl Name, FreeVars)
-rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _, fid_defn = defn })
+rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon
+                                  ,  fid_pats = HsWB { hswb_cts = pats }
+                                  , fid_defn = defn })
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
        ; let loc = case pats of
                      []             -> pprPanic "rnFamInstDecl" (ppr tycon)
@@ -494,8 +495,9 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
              (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
 
 
-       ; kv_names <- mkTyVarBndrNames mb_cls (map (L loc) kv_rdr_names)
-       ; tv_names <- mkTyVarBndrNames mb_cls (map (L loc) tv_rdr_names)
+       ; rdr_env  <- getLocalRdrEnv
+       ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
+       ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
        	     -- All the free vars of the family patterns
              -- with a sensible binding location
        ; ((pats', defn'), fvs) 
@@ -516,8 +518,8 @@ rnFamInstDecl mb_cls (FamInstDecl { fid_tycon = tycon, fid_pats = HsBSig pats _,
 
        ; let all_fvs = fvs `addOneFV` unLoc tycon'
        ; return ( FamInstDecl { fid_tycon = tycon'
-                              , fid_pats = HsBSig pats' (kv_names, tv_names)
-                              , fid_defn = defn', fid_fvs = all_fvs }
+                              , fid_pats  = HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names }
+                              , fid_defn  = defn', fid_fvs = all_fvs }
                 , all_fvs ) }
        	     -- type instance => use, hence addOneFV
 \end{code}
@@ -543,13 +545,13 @@ For the method bindings in class and instance decls, we extend the
 type variable environment iff -fglasgow-exts
 
 \begin{code}
-extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
+extendTyVarEnvForMethodBinds :: LHsTyVarBndrs Name
                              -> RnM (Bag (LHsBind Name), FreeVars)
                              -> RnM (Bag (LHsBind Name), FreeVars)
 extendTyVarEnvForMethodBinds tyvars thing_inside
   = do	{ scoped_tvs <- xoptM Opt_ScopedTypeVariables
 	; if scoped_tvs then
-		extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
+		extendTyVarEnvFVRn (hsLTyVarNames tyvars) thing_inside
 	  else
 		thing_inside }
 \end{code}
@@ -584,7 +586,8 @@ standaloneDerivErr
 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
   = do { let rdr_names_w_loc = map get_var vars
-       ; checkDupAndShadowedRdrNames rdr_names_w_loc
+       ; checkDupRdrNames rdr_names_w_loc
+       ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
        ; bindHsRuleVars rule_name vars names $ \ vars' -> 
     do { (lhs', fv_lhs') <- rnLExpr lhs
@@ -610,7 +613,7 @@ bindHsRuleVars rule_name vars names thing_inside
         thing_inside (RuleBndr (L loc n) : vars')
 
     go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside
-      = rnHsBndrSig True doc bsig $ \ bsig' ->
+      = rnHsBndrSig doc bsig $ \ bsig' ->
         go vars ns $ \ vars' ->
         thing_inside (RuleBndrSig (L loc n) bsig' : vars')
 
@@ -841,38 +844,40 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
 -- in a class decl
 rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
                             , tcdFlavour = flav, tcdKindSig = kind })
-  = do { let tv_rdr_names = hsLTyVarLocNames tyvars
-       ; checkDupRdrNames tv_rdr_names     -- Check for duplicated bindings
-       ; tv_names <- mkTyVarBndrNames mb_cls tv_rdr_names
-       ; bindTyVarsRn fmly_doc tyvars tv_names $ \tyvars' ->
+  = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
     do { tycon' <- lookupLocatedTopBndrRn tycon
        ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
        ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
                            , tcdFlavour = flav, tcdKindSig = kind' }
-                , fv_kind) } }
+                , fv_kind ) }
   where 
      fmly_doc = TyFamilyCtx tycon
+     kvs = extractRdrKindSigVars kind
 
 -- "data", "newtype" declarations
 -- both top level and (for an associated type) in an instance decl
-rnTyClDecl _ (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
+rnTyClDecl mb_cls (TyDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdTyDefn = defn })
   = do { tycon' <- lookupLocatedTopBndrRn tycon
-       ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) tyvars $ \ tyvars' ->
+       ; let kvs = extractTyDefnKindVars defn
+       ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
+       ; ((tyvars', defn'), fvs) <- bindHsTyVars (TyDataCtx tycon) mb_cls kvs tyvars $ \ tyvars' ->
                                     do { (defn', fvs) <- rnTyDefn tycon defn
                                        ; return ((tyvars', defn'), fvs) }
        ; return (TyDecl { tcdLName = tycon', tcdTyVars = tyvars'
                         , tcdTyDefn = defn', tcdFVs = fvs }, fvs) }
 
-rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
-		         tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
-		         tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
-                         tcdDocs = docs})
+rnTyClDecl mb_cls (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
+		              tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
+		              tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
+                              tcdDocs = docs})
   = do	{ lcls' <- lookupLocatedTopBndrRn lcls
         ; let cls' = unLoc lcls'
+              kvs = []  -- No scoped kind vars except those in 
+                        -- kind signatures on the tyvars
 
 	-- Tyvars scope over superclass context and method signatures
 	; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
-	    <- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do
+	    <- bindHsTyVars cls_doc mb_cls kvs tyvars $ \ tyvars' -> do
          	 -- Checks for distinct tyvars
 	     { (context', cxt_fvs) <- rnContext cls_doc context
 	     ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
@@ -1043,21 +1048,6 @@ is jolly confusing.  See Trac #4875
 
 \begin{code}
 ---------------
-mkTyVarBndrNames :: Maybe a -> [Located RdrName] -> RnM [Name]
-mkTyVarBndrNames Nothing tv_rdr_names
-  = newLocalBndrsRn tv_rdr_names
-mkTyVarBndrNames (Just _) tv_rdr_names
-  = do { rdr_env <- getLocalRdrEnv
-       ; let mk_tv_name :: Located RdrName -> RnM Name
-              -- Use the same Name as the parent class decl
-             mk_tv_name (L l tv_rdr)
-               = case lookupLocalRdrEnv rdr_env tv_rdr of 
-                    Just n  -> return n
-                    Nothing -> newLocalBndrRn (L l tv_rdr)
-
-       ; mapM mk_tv_name tv_rdr_names }
-
----------------
 badAssocRhs :: [Name] -> RnM ()
 badAssocRhs ns
   = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") 
@@ -1082,22 +1072,21 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 	   -- For GADT syntax, the tvs are all the quantified tyvars
 	   -- Hence the 'filter' in the ResTyH98 case only
         ; rdr_env <- getLocalRdrEnv
-        ; let in_scope tv  = tv `elemLocalRdrEnv` rdr_env
-	      arg_tys      = hsConDeclArgTys details
-	      mentioned_tvs = case res_ty of
-	      	    	       ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
-	      	    	       ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
+        ; let arg_tys    = hsConDeclArgTys details
+	      (free_kvs, free_tvs) = case res_ty of
+	      	    	       	       ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
+	      	    	       	       ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 
          -- With an Explicit forall, check for unused binders
 	 -- With Implicit, find the mentioned ones, and use them as binders
 	; new_tvs <- case expl of
-	    	       Implicit -> return (userHsTyVarBndrs loc mentioned_tvs)
-            	       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs
+	    	       Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
+            	       Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
                                       ; return tvs }
 
         ; mb_doc' <- rnMbLHsDoc mb_doc 
 
-        ; bindHsTyVars doc new_tvs $ \new_tyvars -> do
+        ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
 	{ (new_context, fvs1) <- rnContext doc lcxt
 	; (new_details, fvs2) <- rnConDeclDetails doc details
         ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
@@ -1106,7 +1095,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
                   fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
  where
     doc = ConDeclCtx name
-    get_rdr_tvs tys = snd (extractHsTysRdrTyVars (cxt ++ tys))
+    get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
 
 rnConResult :: HsDocContext -> Name
             -> HsConDetails (LHsType Name) [ConDeclField Name]
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 99401faefc..1b2e8417f3 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -16,7 +16,7 @@ module RnTypes (
 	rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind, rnLHsMaybeKind,
 	rnHsSigType, rnLHsInstType, rnConDeclFields,
-        rnIPName,
+        rnIPName, newTyVarNameRn,
 
 	-- Precence related stuff
 	mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
@@ -26,9 +26,9 @@ module RnTypes (
 	rnSplice, checkTH,
 
         -- Binding related stuff
-        bindSigTyVarsFV, bindHsTyVars, bindTyVarsRn, rnHsBndrSig,
-        extractHsTyRdrTyVars, extractHsTysRdrTyVars
-
+        bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
+        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+        extractRdrKindSigVars, extractTyDefnKindVars, filterInScope
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -54,8 +54,9 @@ import BasicTypes	( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi
 			  Fixity(..), FixityDirection(..) )
 import Outputable
 import FastString
+import Maybes
 import Data.List        ( nub )
-import Control.Monad	( unless )
+import Control.Monad	( unless, when )
 
 #include "HsVersions.h"
 \end{code}
@@ -78,7 +79,7 @@ rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
 rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
 -- Rename the type in an instance or standalone deriving decl
 rnLHsInstType doc_str ty 
-  = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty
+  = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
        ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
        ; return (ty', fvs) }
   where
@@ -108,13 +109,13 @@ rnLHsType = rnLHsTyKi True
 rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
 rnLHsKind = rnLHsTyKi False
 
-rnLHsMaybeKind  :: HsDocContext -> Maybe (HsBndrSig (LHsKind RdrName))
-                -> RnM (Maybe (HsBndrSig (LHsKind Name)), FreeVars)
+rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
+                -> RnM (Maybe (LHsKind Name), FreeVars)
 rnLHsMaybeKind _ Nothing 
   = return (Nothing, emptyFVs)
-rnLHsMaybeKind doc (Just bsig) 
-  = rnHsBndrSig False doc bsig $ \ bsig' -> 
-    return (Just bsig', emptyFVs)
+rnLHsMaybeKind doc (Just kind) 
+  = do { (kind', fvs) <- rnLHsKind doc kind
+       ; return (Just kind', fvs) }
 
 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
 rnHsType = rnHsTyKi True
@@ -128,33 +129,33 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty)
 	-- Implicit quantifiction in source code (no kinds on tyvars)
 	-- Given the signature  C => T  we universally quantify 
 	-- over FV(T) \ {in-scope-tyvars} 
-    name_env <- getLocalRdrEnv
+    rdr_env <- getLocalRdrEnv
     loc <- getSrcSpanM
     let
-	(_kvs, mentioned) = extractHsTysRdrTyVars (ty:ctxt)
+	(forall_kvs, forall_tvs) = filterInScope rdr_env $
+                                   extractHsTysRdrTyVars (ty:ctxt)
            -- In for-all types we don't bring in scope
            -- kind variables mentioned in kind signatures
            -- (Well, not yet anyway....)
            --    f :: Int -> T (a::k)    -- Not allowed
 
-	-- Don't quantify over type variables that are in scope;
-	-- when GlasgowExts is off, there usually won't be any, except for
-	-- class signatures:
-	--	class C a where { op :: a -> a }
-	forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned
-	tyvar_bndrs   = userHsTyVarBndrs loc forall_tyvars
+           -- The filterInScope is to ensure that we don't quantify over
+	   -- type variables that are in scope; when GlasgowExts is off,
+	   -- there usually won't be any, except for class signatures:
+	   --	class C a where { op :: a -> a }
+	tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
 
-    rnForAll doc Implicit tyvar_bndrs lctxt ty
+    rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
 
 rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau)
   = ASSERT ( isType ) do { 	-- Explicit quantification.
          -- Check that the forall'd tyvars are actually 
 	 -- mentioned in the type, and produce a warning if not
-         let (_kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
+         let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
              in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
        ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
 
-       ; rnForAll doc Explicit forall_tyvars lctxt tau }
+       ; rnForAll doc Explicit kvs forall_tyvars lctxt tau }
 
 rnHsTyKi isType _ (HsTyVar rdr_name)
   = do { name <- rnTyVar isType rdr_name
@@ -310,11 +311,15 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
 
 
 \begin{code}
-rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
+rnForAll :: HsDocContext -> HsExplicitFlag 
+         -> [RdrName]                -- Kind variables
+         -> LHsTyVarBndrs RdrName   -- Type variables
 	 -> LHsContext RdrName -> LHsType RdrName 
          -> RnM (HsType Name, FreeVars)
 
-rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
+rnForAll doc exp kvs forall_tyvars ctxt ty
+  | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt)
+  = rnHsType doc (unLoc ty)
 	-- One reason for this case is that a type like Int#
 	-- starts off as (HsForAllTy Nothing [] Int), in case
 	-- there is some quantification.  Now that we have quantified
@@ -323,8 +328,8 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
 	-- get an error, because the body of a genuine for-all is
 	-- of kind *.
 
-rnForAll doc exp forall_tyvars ctxt ty
-  = bindHsTyVars doc forall_tyvars $ \ new_tyvars ->
+  | otherwise
+  = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
     do { (new_ctxt, fvs1) <- rnContext doc ctxt
        ; (new_ty, fvs2) <- rnLHsType doc ty
        ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
@@ -346,51 +351,70 @@ bindSigTyVarsFV tvs thing_inside
 		bindLocalNamesFV tvs thing_inside }
 
 ---------------
-bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName]
-	      -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-	      -> RnM (a, FreeVars)
-bindHsTyVars doc tv_bndrs thing_inside
-  = do { checkDupAndShadowedRdrNames rdr_names_w_loc
-       ; names <- newLocalBndrsRn rdr_names_w_loc
-       ; bindTyVarsRn doc tv_bndrs names thing_inside }
-  where
-    rdr_names_w_loc = hsLTyVarLocNames tv_bndrs
-
----------------
-bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] -> [Name]
-	     -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-	     -> RnM (a, FreeVars)
--- Rename the HsTyVarBndrs, giving them the specified names
--- *and* bringing into scope the kind variables bound in 
--- any kind signatures
-
-bindTyVarsRn doc tv_bndrs names thing_inside
-  = go tv_bndrs names $ \ tv_bndrs' -> 
-    bindLocalNamesFV names (thing_inside tv_bndrs')
-  where
-    go [] [] thing_inside = thing_inside []
-
-    go (L loc (UserTyVar _) : tvs) (n : ns) thing_inside
-      = go tvs ns $ \ tvs' ->
-        thing_inside (L loc (UserTyVar n) : tvs')
-
-    go (L loc (KindedTyVar _ bsig) : tvs) (n : ns) thing_inside
-      = rnHsBndrSig False doc bsig $ \ bsig' ->
-        go tvs ns $ \ tvs' ->
-        thing_inside (L loc (KindedTyVar n bsig') : tvs')
+bindHsTyVars :: HsDocContext 
+             -> Maybe a                 -- Just _  => an associated type decl
+             -> [RdrName]               -- Kind variables from scope
+             -> LHsTyVarBndrs RdrName   -- Type variables
+             -> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
+             -> RnM (b, FreeVars)
+-- (a) Bring kind variables into scope 
+--     both (i) passed in (kv_bndrs) and (ii) mentioned in the kinds of tv_bndrs
+-- (b) Bring type variables into scope
+bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
+  = do { rdr_env <- getLocalRdrEnv
+       ; let tvs = hsQTvBndrs tv_bndrs
+             kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
+                                 , let (_, kvs) = extractHsTyRdrTyVars kind
+                                 , kv <- kvs ]
+             all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $
+                       nub (kv_bndrs ++ kvs_from_tv_bndrs)
+       ; poly_kind <- xoptM Opt_PolyKinds
+       ; unless (poly_kind || null all_kvs) 
+                (addErr (badKindBndrs doc all_kvs))
+       ; loc <- getSrcSpanM
+       ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
+       ; bindLocalNamesFV kv_names $ 
+    do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
+
+    	     rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
+    	     rn_tv_bndr (L loc (UserTyVar rdr)) 
+    	       = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+    	            ; return (L loc (UserTyVar nm), emptyFVs) }
+    	     rn_tv_bndr (L loc (KindedTyVar rdr kind)) 
+    	       = do { sig_ok <- xoptM Opt_KindSignatures
+                    ; unless sig_ok (badSigErr False doc kind)
+                    ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
+    	            ; (kind', fvs) <- rnLHsKind doc kind
+    	            ; return (L loc (KindedTyVar nm kind'), fvs) }
+
+       -- Check for duplicate or shadowed tyvar bindrs
+       ; checkDupRdrNames tv_names_w_loc
+       ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
+
+       ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
+       ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
+                        do { env <- getLocalRdrEnv
+                           ; traceRn (text "bhtv" <+> (ppr tvs $$ ppr all_kvs $$ ppr env))
+                           ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
+       ; return (res, fvs1 `plusFV` fvs2) } }
 
-    -- Lists of unequal length
-    go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)
+newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
+newTyVarNameRn mb_assoc rdr_env loc rdr
+  | Just _ <- mb_assoc    -- Use the same Name as the parent class decl
+  , Just n <- lookupLocalRdrEnv rdr_env rdr
+  = return n   
+  | otherwise 
+  = newLocalBndrRn (L loc rdr)
 
 --------------------------------
-rnHsBndrSig :: Bool    -- True <=> type sig, False <=> kind sig
-            -> HsDocContext
-            -> HsBndrSig (LHsType RdrName)
-            -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars))
+rnHsBndrSig :: HsDocContext
+            -> HsWithBndrs (LHsType RdrName)
+            -> (HsWithBndrs (LHsType Name) -> RnM (a, FreeVars))
             -> RnM (a, FreeVars)
-rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside
-  = do { let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
-       ; checkHsBndrFlags is_type doc ty tv_bndrs 
+rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
+  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
+       ; unless sig_ok (badSigErr True doc ty)
+       ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
        ; name_env <- getLocalRdrEnv
        ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
                                                , not (tv `elemLocalRdrEnv` name_env) ]
@@ -398,26 +422,13 @@ rnHsBndrSig is_type doc (HsBSig ty@(L loc _) _) thing_inside
                                                , not (kv `elemLocalRdrEnv` name_env) ]
        ; bindLocalNamesFV kv_names $ 
          bindLocalNamesFV tv_names $ 
-    do { (ty', fvs1) <- rnLHsTyKi is_type doc ty
-       ; (res, fvs2) <- thing_inside (HsBSig ty' (kv_names, tv_names))
+    do { (ty', fvs1) <- rnLHsType doc ty
+       ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names })
        ; return (res, fvs1 `plusFV` fvs2) } }
 
-checkHsBndrFlags :: Bool -> HsDocContext 
-                 -> LHsType RdrName -> [RdrName] -> RnM ()
-checkHsBndrFlags is_type doc ty tv_bndrs
-  | is_type     -- Type
-  = do { sig_ok <- xoptM Opt_ScopedTypeVariables
-       ; unless sig_ok (badSigErr True doc ty) }
-  | otherwise   -- Kind
-  = do { sig_ok <- xoptM Opt_KindSignatures
-       ; unless sig_ok (badSigErr False doc ty)
-       ; poly_kind <- xoptM Opt_PolyKinds
-       ; unless (poly_kind || null tv_bndrs) 
-                (addErr (badKindBndrs doc ty tv_bndrs)) }
-
-badKindBndrs :: HsDocContext -> LHsKind RdrName -> [RdrName] -> SDoc
-badKindBndrs doc _kind kvs
-  = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs
+badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
+badKindBndrs doc kvs
+  = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
                  <+> pprQuotedList kvs)
               2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
          , docOfHsDocContext doc ]
@@ -779,7 +790,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
 %*********************************************************
 
 \begin{code}
-warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [RdrName] -> TcM ()
+warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
 warnUnusedForAlls in_doc bound mentioned_rdrs
   = ifWOptM Opt_WarnUnusedMatches $
     mapM_ add_warn bound_but_not_used
@@ -868,8 +879,6 @@ checkTH e what 	-- Raise an error in a stage-1 compiler
 %*                                                                    *
 %************************************************************************
 
-extractHsTyRdrNames finds the free variables of a HsType
-It's used when making the for-alls explicit.
 
 Note [Kind and type-variable binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -902,7 +911,16 @@ See also Note [HsBSig binder lists] in HsTypes
 \begin{code}
 type FreeKiTyVars = ([RdrName], [RdrName])
 
+filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
+filterInScope rdr_env (kvs, tvs) 
+  = (filterOut in_scope kvs, filterOut in_scope tvs)
+  where
+    in_scope tv = tv `elemLocalRdrEnv` rdr_env
+
 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
+-- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
+--                        or the free (sort, kind) variables of a HsKind
+-- It's used when making the for-alls explicit.
 -- See Note [Kind and type-variable binders]
 extractHsTyRdrTyVars ty 
   = case extract_lty ty ([],[]) of
@@ -914,12 +932,46 @@ extractHsTysRdrTyVars ty
   = case extract_ltys ty ([],[]) of
      (kvs, tvs) -> (nub kvs, nub tvs)
 
+extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
+extractRdrKindSigVars Nothing = []
+extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
+
+extractTyDefnKindVars :: HsTyDefn RdrName -> [RdrName]
+-- Get the scoped kind variables mentioned free in the constructor decls
+-- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
+-- Here k should scope over the whole definition
+extractTyDefnKindVars (TySynonym { td_synRhs = ty}) 
+  = fst (extractHsTyRdrTyVars ty)
+extractTyDefnKindVars (TyData { td_ctxt = ctxt, td_kindSig = ksig
+                              , td_cons = cons, td_derivs = derivs })
+  = fst $ extract_lctxt ctxt $
+          extract_mb extract_lkind ksig $
+          extract_mb extract_ltys derivs $
+          foldr (extract_con . unLoc) ([],[]) cons
+  where
+    extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
+    extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
+                         , con_cxt = ctxt, con_details = details }) acc
+      = extract_hs_tv_bndrs qvs acc $
+        extract_lctxt ctxt $
+        extract_ltys (hsConDeclArgTys details) ([],[])
+
+
 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
-extract_lctxt ctxt acc = foldr extract_lty acc (unLoc ctxt)
+extract_lctxt ctxt = extract_ltys (unLoc ctxt)
 
 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
 extract_ltys tys acc = foldr extract_lty acc tys
 
+extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
+extract_mb _ Nothing  acc = acc
+extract_mb f (Just x) acc = f x acc
+
+extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
+extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
+                                          (_, res_kvs) -> (res_kvs, acc_tvs)
+                                        -- Kinds shouldn't have sort signatures!
+
 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_lty (L _ ty) acc
   = case ty of
@@ -943,19 +995,27 @@ extract_lty (L _ ty) acc
       HsExplicitTupleTy _ tys   -> extract_ltys tys acc
       HsTyLit _                 -> acc
       HsWrapTy _ _              -> panic "extract_lty"
-      HsKindSig ty ki           -> case extract_lty ty acc of { (kvs1, tvs) ->
-                                   case extract_lty ki ([],kvs1) of { (_, kvs2) -> 
-                                        -- Kinds shouldn't have sort signatures!
-                                   (kvs2, tvs) }}
-      HsForAllTy _ [] cx ty     -> extract_lctxt cx (extract_lty ty acc)
-      HsForAllTy _ tvs cx ty    -> (acc_kvs ++ body_kvs, 
-                                    acc_tvs ++ filterOut (`elem` locals_tvs) body_tvs)
-                                where
-                                   (body_kvs, body_tvs) = extract_lctxt cx (extract_lty ty ([],[]))
-                                   (acc_kvs, acc_tvs) = acc
-                                   locals_tvs = hsLTyVarNames tvs
-                                        -- Currently we don't have a syntax to explicity bind 
-                                        -- kind variables, so these are all type variables
+      HsKindSig ty ki           -> extract_lty ty (extract_lkind ki acc)
+      HsForAllTy _ tvs cx ty    -> extract_hs_tv_bndrs tvs acc $
+                                   extract_lctxt cx   $
+                                   extract_lty ty ([],[])
+
+extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
+                    -> FreeKiTyVars -> FreeKiTyVars
+extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) 
+                    acc@(acc_kvs, acc_tvs)   -- Note accumulator comes first
+                    (body_kvs, body_tvs)
+  | null tvs
+  = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
+  | otherwise
+  = (outer_kvs ++ body_kvs,
+     outer_tvs ++ filterOut (`elem` local_tvs) body_tvs)
+  where
+    local_tvs = map hsLTyVarName tvs
+        -- Currently we don't have a syntax to explicitly bind 
+        -- kind variables, so these are all type variables
+
+    (outer_kvs, outer_tvs) = foldr extract_lkind acc [k | L _ (KindedTyVar _ k) <- tvs]
 
 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_tv tv acc
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 78798b64ad..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
-	DupFlag 	                -- See Note [DupFlag invariants]
-	InId InType [InAlt] StaticEnv	-- The case binder, alts type, alts, and subst-env
+  | Select   		-- case <hole> of alts
+	DupFlag 	        -- See Note [DupFlag invariants]
+	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,18 +158,19 @@ 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 (ApplyTo dup arg _ cont)         = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
+  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
-  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 ty alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr <+> ppr ty) $$ 
+  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 
-  ppr (CoerceIt co cont)	       = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
-  ppr (TickIt t cont)                  = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
+  ppr (CoerceIt co cont)	     = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
+  ppr (TickIt t cont)                = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
 
 data DupFlag = NoDup       -- Unsimplified, might be big
              | Simplified  -- Simplified
@@ -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
@@ -211,11 +216,11 @@ contIsRhsOrArg _               = False
 
 -------------------
 contIsDupable :: SimplCont -> Bool
-contIsDupable (Stop {})                    = True
-contIsDupable (ApplyTo  OkToDup _ _ _)     = True	-- See Note [DupFlag invariants]
-contIsDupable (Select   OkToDup _ _ _ _ _) = True -- ...ditto...
-contIsDupable (CoerceIt _ cont)            = contIsDupable cont
-contIsDupable _                            = False
+contIsDupable (Stop {})                  = True
+contIsDupable (ApplyTo  OkToDup _ _ _)   = True	-- See Note [DupFlag invariants]
+contIsDupable (Select   OkToDup _ _ _ _) = True -- ...ditto...
+contIsDupable (CoerceIt _ cont)          = contIsDupable cont
+contIsDupable _                          = False
 
 -------------------
 contIsTrivial :: 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 _ _ ty _ se cont)      _  = go cont (subst_ty se ty)
-    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
@@ -328,7 +333,7 @@ interestingCallContext :: SimplCont -> CallCtxt
 interestingCallContext cont
   = interesting cont
   where
-    interesting (Select _ bndr _ _ _ _)
+    interesting (Select _ bndr _ _ _)
 	| isDeadBinder bndr = CaseCtxt
 	| otherwise	    = ArgCtxt False	-- If the binder is used, this
 						-- is like a strict let
@@ -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
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 8b361b0bc9..56e0bededd 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -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,17 +947,19 @@ simplExprF1 env expr@(Lam {}) cont
     zap b | isTyVar b = b
           | otherwise = zapLamIdInfo b
 
-simplExprF1 env (Case scrut bndr ty 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 ty alts env cont)
+    simplExprF env scrut (Select NoDup bndr alts env 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 ty 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)
@@ -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
@@ -1160,7 +1168,7 @@ rebuild env 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 ty alts se cont -> rebuildCase (se `setFloats` env) expr bndr ty alts cont
+      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 }
@@ -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
@@ -1440,14 +1448,14 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
   = return (env, castBottomExpr res cont_ty)  -- contination to discard, else we do it
   where                                       -- again and again!
     res     = mkApps (Var fun) (reverse rev_args)
-    cont_ty = contResultType env (exprType res) cont
+    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]
@@ -1465,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 }
@@ -1728,7 +1736,6 @@ rebuildCase, reallyRebuildCase
    :: SimplEnv
    -> OutExpr          -- Scrutinee
    -> InId             -- Case binder
-   -> InType           -- Type of alternatives
    -> [InAlt]          -- Alternatives (inceasing order)
    -> SimplCont
    -> SimplM (SimplEnv, OutExpr)
@@ -1737,7 +1744,7 @@ rebuildCase, reallyRebuildCase
 --      1. Eliminate the case if there's a known constructor
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr _ alts cont
+rebuildCase env scrut case_bndr alts cont
   | Lit lit <- scrut    -- No need for same treatment as constructors
                         -- because literals are inlined more vigorously
   , not (litIsLifted lit)
@@ -1766,7 +1773,7 @@ rebuildCase env scrut case_bndr _ alts cont
 --      2. Eliminate the case if scrutinee is evaluated
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr _ [(_, bndrs, rhs)] cont
+rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
   -- See if we can get rid of the case altogether
   -- See Note [Case elimination] 
   -- mkCase made sure that if all the alternatives are equal,
@@ -1816,7 +1823,7 @@ rebuildCase env scrut case_bndr _ [(_, bndrs, rhs)] cont
 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr alts_ty alts@[(_, bndrs, rhs)] cont
+rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
   | all isDeadBinder (case_bndr : bndrs)  -- So this is just 'seq'
   = do { let rhs' = substExpr (text "rebuild-case") env rhs
              out_args = [Type (substTy env (idType case_bndr)), 
@@ -1829,24 +1836,25 @@ rebuildCase env scrut case_bndr alts_ty alts@[(_, bndrs, rhs)] cont
            Just (n_args, res) -> simplExprF (zapSubstEnv env) 
 	   	       		    	    (mkApps res (drop n_args out_args))
                                             cont
-	   Nothing -> reallyRebuildCase env scrut case_bndr alts_ty alts cont }
+	   Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
 
-rebuildCase env scrut case_bndr alts_ty alts cont
-  = reallyRebuildCase env scrut case_bndr alts_ty alts cont
+rebuildCase env scrut case_bndr alts cont
+  = reallyRebuildCase env scrut case_bndr alts cont
 
 --------------------------------------------------
 --      3. Catch-all case
 --------------------------------------------------
 
-reallyRebuildCase env scrut case_bndr alts_ty alts cont
+reallyRebuildCase env scrut case_bndr alts cont
   = do  {       -- Prepare the continuation;
                 -- The new subst_env is in place
           (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
 
         -- Simplify the alternatives
-        ; (scrut', case_bndr', alts_ty', alts') <- simplAlts env' scrut case_bndr alts_ty alts dup_cont
+        ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
 
         ; 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
@@ -1935,20 +1943,16 @@ robust here.  (Otherwise, there's a danger that we'll simply drop the
 simplAlts :: SimplEnv
           -> OutExpr
           -> InId                       -- Case binder
-          -> InType
           -> [InAlt]			-- Non-empty
 	  -> SimplCont
-          -> SimplM (OutExpr, OutId, OutType, [OutAlt])  -- Includes the continuation
+          -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
 -- Like simplExpr, this just returns the simplified alternatives;
 -- it does not return an environment
 -- The returned alternatives can be empty, none are possible
 
-simplAlts env scrut case_bndr alts_ty alts cont'
+simplAlts env scrut case_bndr alts cont'
   = do  { let env0 = zapFloats env
 
-        ; basic_alts_ty' <- simplType env0 alts_ty
-        ; let alts_ty' = contResultType env0 basic_alts_ty' cont'
-
         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
 
         ; fam_envs <- getFamEnvs
@@ -1963,7 +1967,7 @@ simplAlts env scrut case_bndr alts_ty alts cont'
         ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
                              imposs_deflt_cons case_bndr' cont') in_alts
         ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
-          return (scrut', case_bndr', alts_ty', alts') }
+          return (scrut', case_bndr', alts') }
 
 
 ------------------------------------
@@ -2180,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}
 
 
@@ -2212,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]
@@ -2241,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
 
@@ -2251,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)
@@ -2274,16 +2276,16 @@ mkDupableCont env (ApplyTo _ arg se cont)
         ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
         ; return (env'', app_cont, nodup_cont) }
 
-mkDupableCont env cont@(Select _ case_bndr _ [(_, bs, _rhs)] _ _)
+mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
 --  See Note [Single-alternative case]
 --  | not (exprIsDupable rhs && contIsDupable case_cont)
 --  | not (isDeadBinder case_bndr)
   | 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_ty alts se cont)
+mkDupableCont env (Select _ case_bndr alts se cont)
   =     -- e.g.         (case [...hole...] of { pi -> ei })
         --      ===>
         --              let ji = \xij -> ei
@@ -2299,8 +2301,6 @@ mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
 
         ; let alt_env = se `setInScope` env'
 
-        ; basic_alts_ty' <- simplType alt_env alts_ty
-        ; let alts_ty' = contResultType alt_env basic_alts_ty' dup_cont
         ; (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
@@ -2317,7 +2317,8 @@ mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
 
         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
         ; return (env'',  -- Note [Duplicated env]
-                  Select OkToDup case_bndr' alts_ty' alts'' (zapSubstEnv env'') mkBoringStop,
+                  Select OkToDup case_bndr' alts'' (zapSubstEnv env'') 
+                         (mkBoringStop (contInputType nodup_cont)),
                   nodup_cont) }
 
 
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 020d42c1ba..483de071d4 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -158,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) }
@@ -231,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 })
 
@@ -316,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
@@ -425,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
@@ -434,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
 
@@ -571,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
@@ -1066,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
@@ -1079,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)
@@ -1092,7 +1091,7 @@ solverDepthErrorTcS depth stack
 -}
 
 
-flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a
+flattenForAllErrorTcS :: CtEvidence -> TcType -> TcM a
 flattenForAllErrorTcS fl ty
   = setCtFlavorLoc fl $ 
     do { env0 <- tcInitTidyEnv
@@ -1109,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..09704fbfd1 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
@@ -238,7 +242,8 @@ coVarsOfTcCo tc_co
     go (TcNthCo _ co)            = go co
     go (TcLetCo (EvBinds bs) co) = foldrBag (unionVarSet . go_bind) (go co) bs
                                    `minusVarSet` get_bndrs bs
-    go (TcLetCo {}) = pprPanic "coVarsOfTcCo called on non-zonked TcCoercion" (ppr tc_co)
+    go (TcLetCo {}) = emptyVarSet    -- Harumph. This does legitimately happen in the call
+                                     -- to evVarsOfTerm in the DEBUG check of setEvBind
 
     -- We expect only coercion bindings
     go_bind :: EvBind -> VarSet
@@ -263,7 +268,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 +294,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
@@ -449,29 +456,29 @@ evBindMapBinds bs
 data EvBind = EvBind EvVar EvTerm
 
 data EvTerm
-  = EvId EvId                    -- Term-level variable-to-variable bindings
-                                 -- (no coercion variables! they come via EvCoercion)
+  = EvId EvId                    -- Any sort of evidence Id, including coercions
 
-  | EvCoercion TcCoercion        -- (Boxed) coercion bindings
+  | EvCoercion TcCoercion        -- (Boxed) coercion bindings 
+                                 -- See Note [Coercion evidence terms]
 
-  | 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]
@@ -486,6 +493,29 @@ data EvLit
 
 \end{code}
 
+Note [Coecion evidence terms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that a coercion variable (v :: t1 ~ t2) can be represented as an EvTerm
+in two different ways:
+   EvId v
+   EvCoercion (TcCoVarCo v)
+
+An alternative would be 
+
+* To establish the invariant that coercions are represented only 
+   by EvCoercion
+
+* To maintain the invariant by smart constructors.  Eg
+     mkEvCast (EvCoercion c1) c2 = EvCoercion (TcCastCo c1 c2)
+     mkEvCast t c = EvCast t c
+
+We do quite often need to get a TcCoercion from an EvTerm; see
+'evTermCoercion'.  Notice that as well as EvId and EvCoercion it may see
+an EvCast.
+
+I don't think it matters much... but maybe we'll find a good reason to
+do one or the other.
+
 Note [EvKindCast] 
 ~~~~~~~~~~~~~~~~~ 
 EvKindCast g kco is produced when we have a constraint (g : s1 ~ s2) 
@@ -555,14 +585,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 +603,28 @@ 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)
+-- See Note [Coercion evidence terms]
+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/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index aec09e914d..9104016938 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -1095,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
@@ -1344,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/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 24cd4422c5..b780c3b2e0 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -783,24 +783,19 @@ then we'd also need
                           since we only have BOX for a super kind)
 
 \begin{code}
-bindScopedKindVars :: [LHsTyVarBndr Name] -> TcM a -> TcM a
+bindScopedKindVars :: [Name] -> TcM a -> TcM a
 -- Given some tyvar binders like [a (b :: k -> *) (c :: k)]
 -- bind each scoped kind variable (k in this case) to a fresh
 -- kind skolem variable
-bindScopedKindVars hs_tvs thing_inside
-  = tcExtendTyVarEnv kvs thing_inside
-  where
-    kvs :: [KindVar]   -- All skolems
-    kvs = [ mkKindSigVar kv 
-          | L _ (KindedTyVar _ (HsBSig _ (_, kvs))) <- hs_tvs
-          , kv <- kvs ]
+bindScopedKindVars kvs thing_inside 
+  = tcExtendTyVarEnv (map mkKindSigVar kvs) thing_inside
 
-tcHsTyVarBndrs :: [LHsTyVarBndr Name] 
+tcHsTyVarBndrs :: LHsTyVarBndrs Name 
 	       -> ([TyVar] -> TcM r)
 	       -> TcM r
 -- Bind the type variables to skolems, each with a meta-kind variable kind
-tcHsTyVarBndrs hs_tvs thing_inside
-  = bindScopedKindVars hs_tvs $
+tcHsTyVarBndrs (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
+  = bindScopedKindVars kvs $
     do { tvs <- mapM tcHsTyVarBndr hs_tvs
        ; traceTc "tcHsTyVarBndrs" (ppr hs_tvs $$ ppr tvs)
        ; tcExtendTyVarEnv tvs (thing_inside tvs) }
@@ -825,7 +820,7 @@ tcHsTyVarBndr (L _ hs_tv)
            _ -> do
        { kind <- case hs_tv of
                    UserTyVar {} -> newMetaKindVar
-                   KindedTyVar _ (HsBSig kind _) -> tcLHsKind kind
+                   KindedTyVar _ kind -> tcLHsKind kind
        ; return (mkTcTyVar name kind (SkolemTv False)) } } }
 
 ------------------
@@ -896,11 +891,11 @@ kcLookupKind nm
            AGlobal (ATyCon tc) -> return (tyConKind tc)
            _                   -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
 
-kcTyClTyVars :: Name -> [LHsTyVarBndr Name] -> (TcKind -> TcM a) -> TcM a
+kcTyClTyVars :: Name -> LHsTyVarBndrs Name -> (TcKind -> TcM a) -> TcM a
 -- Used for the type variables of a type or class decl,
 -- when doing the initial kind-check.  
-kcTyClTyVars name hs_tvs thing_inside
-  = bindScopedKindVars hs_tvs $
+kcTyClTyVars name (HsQTvs { hsq_kvs = kvs, hsq_tvs = hs_tvs }) thing_inside
+  = bindScopedKindVars kvs $
     do 	{ tc_kind <- kcLookupKind name
 	; let (arg_ks, res_k) = splitKindFunTysN (length hs_tvs) tc_kind
                      -- There should be enough arrows, because
@@ -912,7 +907,7 @@ kcTyClTyVars name hs_tvs thing_inside
     kc_tv (L _ (UserTyVar n)) exp_k 
       = do { check_in_scope n exp_k
            ; return (n, exp_k) }
-    kc_tv (L _ (KindedTyVar n (HsBSig hs_k _))) exp_k
+    kc_tv (L _ (KindedTyVar n hs_k)) exp_k
       = do { k <- tcLHsKind hs_k
            ; _ <- unifyKind k exp_k
            ; check_in_scope n exp_k
@@ -930,7 +925,7 @@ kcTyClTyVars name hs_tvs thing_inside
                Just thing      -> pprPanic "check_in_scope" (ppr thing) }
 
 -----------------------
-tcTyClTyVars :: Name -> [LHsTyVarBndr Name]	-- LHS of the type or class decl
+tcTyClTyVars :: Name -> LHsTyVarBndrs Name	-- LHS of the type or class decl
              -> ([TyVar] -> Kind -> TcM a) -> TcM a
 -- Used for the type variables of a type or class decl,
 -- on the second pass when constructing the final result
@@ -1051,16 +1046,16 @@ Historical note:
 
 \begin{code}
 tcHsPatSigType :: UserTypeCtxt
-	       -> HsBndrSig (LHsType Name)  -- The type signature
-	      -> TcM ( Type                 -- The signature
-                      , [(Name, TcTyVar)] ) -- The new bit of type environment, binding
-				            -- the scoped type variables
+	       -> HsWithBndrs (LHsType Name)  -- The type signature
+	      -> TcM ( Type                   -- The signature
+                      , [(Name, TcTyVar)] )   -- The new bit of type environment, binding
+				              -- the scoped type variables
 -- Used for type-checking type signatures in
 -- (a) patterns 	  e.g  f (x::Int) = e
 -- (b) result signatures  e.g. g x :: Int = e
 -- (c) RULE forall bndrs  e.g. forall (x::Int). f x = x
 
-tcHsPatSigType ctxt (HsBSig hs_ty (sig_kvs, sig_tvs))
+tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs, hswb_tvs = sig_tvs })
   = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
     do	{ kvs <- mapM new_kv sig_kvs
         ; tvs <- mapM new_tv sig_tvs
@@ -1081,7 +1076,7 @@ tcHsPatSigType ctxt (HsBSig hs_ty (sig_kvs, sig_tvs))
           _              -> newSigTyVar name kind  -- See Note [Unifying SigTvs]
 
 tcPatSig :: UserTypeCtxt
-	 -> HsBndrSig (LHsType Name)
+	 -> HsWithBndrs (LHsType Name)
 	 -> TcSigmaType
 	 -> TcM (TcType,	    -- The type to use for "inside" the signature
 		 [(Name, TcTyVar)], -- The new bit of type environment, binding
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 884331dbcc..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_cached)
-             -> 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/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 80c792f85d..95274f0814 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -1159,6 +1159,7 @@ setInteractiveContext hsc_env icxt thing_inside
                                        (mkNameSet (concatMap snd con_fields))
              -- setting tcg_field_env is necessary to make RecordWildCards work
              -- (test: ghci049)
+        , tcg_fix_env      = ic_fix_env icxt
         }) $
 
         tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids]
@@ -1171,13 +1172,13 @@ setInteractiveContext hsc_env icxt thing_inside
 -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
 -- values, coerced to ().
 tcRnStmt :: HscEnv -> InteractiveContext -> LStmt RdrName
-         -> IO (Messages, Maybe ([Id], LHsExpr Id))
+         -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv))
 tcRnStmt hsc_env ictxt rdr_stmt
   = initTcPrintErrors hsc_env iNTERACTIVE $
     setInteractiveContext hsc_env ictxt $ do {
 
     -- The real work is done here
-    (bound_ids, tc_expr) <- tcUserStmt rdr_stmt ;
+    ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
     zonked_expr <- zonkTopLExpr tc_expr ;
     zonked_ids  <- zonkTopBndrs bound_ids ;
 
@@ -1212,7 +1213,7 @@ tcRnStmt hsc_env ictxt rdr_stmt
         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
                text "Typechecked expr" <+> ppr zonked_expr]) ;
 
-    return (global_ids, zonked_expr)
+    return (global_ids, zonked_expr, fix_env)
     }
   where
     bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
@@ -1281,7 +1282,7 @@ runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
 -- for more details. We do this lifting by trying different ways ('plans') of
 -- lifting the code into the IO monad and type checking each plan until one
 -- succeeds.
-tcUserStmt :: LStmt RdrName -> TcM PlanResult
+tcUserStmt :: LStmt RdrName -> TcM (PlanResult, FixityEnv)
 
 -- An expression typed at the prompt is treated very specially
 tcUserStmt (L loc (ExprStmt expr _ _ _))
@@ -1319,7 +1320,7 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
         -- naked expression. Deferring type errors here is unhelpful because the
         -- expression gets evaluated right away anyway. It also would potentially
         -- emit two redundant type-error warnings, one from each plan.
-        ; unsetDOptM Opt_DeferTypeErrors $ runPlans [
+        ; plan <- unsetDOptM Opt_DeferTypeErrors $ runPlans [
                     -- Plan A
                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
                        ; it_ty <- zonkTcType (idType it_id)
@@ -1336,14 +1337,17 @@ tcUserStmt (L loc (ExprStmt expr _ _ _))
                         -- This two-step story is very clunky, alas
                     do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
                                 --- checkNoErrs defeats the error recovery of let-bindings
-                       ; tcGhciStmts [let_stmt, print_it] }
-          ]}
+                       ; tcGhciStmts [let_stmt, print_it] } ]
+
+        ; fix_env <- getFixityEnv
+        ; return (plan, fix_env) }
 
 tcUserStmt rdr_stmt@(L loc _)
-  = do { (([rn_stmt], _), fvs) <- checkNoErrs $
-                                  rnStmts GhciStmt [rdr_stmt] $ \_ ->
-                                  return ((), emptyFVs) ;
-               -- Don't try to typecheck if the renamer fails!
+  = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
+           rnStmts GhciStmt [rdr_stmt] $ \_ -> do
+             fix_env <- getFixityEnv
+             return (fix_env, emptyFVs)
+            -- Don't try to typecheck if the renamer fails!
        ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
        ; rnDump (ppr rn_stmt) ;
 
@@ -1363,7 +1367,8 @@ tcUserStmt rdr_stmt@(L loc _)
         -- The plans are:
         --      [stmt; print v]         if one binder and not v::()
         --      [stmt]                  otherwise
-       ; runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]]) }
+       ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
+       ; return (plan, fix_env) }
   where
     mk_print_result_plan stmt v
       = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
@@ -1430,10 +1435,13 @@ getGhciStepIO = do
     let a_tv   = mkTcTyVarName fresh_a (fsLit "a")
         ghciM  = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
         ioM    = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
+
+        stepTy :: LHsType Name    -- Renamed, so needs all binders in place
         stepTy = noLoc $ HsForAllTy Implicit
-                      ([noLoc $ UserTyVar a_tv])
-                      (noLoc [])
-                      (nlHsFunTy ghciM ioM)
+                            (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
+                                    , hsq_kvs = [] })
+                            (noLoc [])
+                            (nlHsFunTy ghciM ioM)
         step   = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy
     return step
 
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..287783cb88 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,15 @@ import TcRnTypes
 
 import Unique 
 import UniqFM
-import Maybes ( orElse )
+#ifdef DEBUG
+import Digraph
+#endif
+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 +300,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 +320,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 +372,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 +406,6 @@ partCtFamHeadMap f ctmap
                       = ty1 
                       | otherwise 
                       = panic "partCtFamHeadMap, encountered non equality!"
-
-
 \end{code}
 
 %************************************************************************
@@ -400,9 +416,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 +481,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 +534,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 +544,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 +553,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 }
-
-type AtomicInert = Ct 
+       , inert_flat_cache    = FamHeadMap emptyTM
+       , inert_solved        = PredMap emptyTM 
+       , inert_solved_funeqs = FamHeadMap emptyTM }
 
-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 +583,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 +613,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 +631,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 +667,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 +711,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 +746,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 +755,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 +765,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}
 
 
@@ -910,10 +963,32 @@ runTcS context untouch is wl tcs
          }
              -- And return
        ; ev_binds <- TcM.getTcEvBinds ev_binds_var
+       ; checkForCyclicBinds ev_binds
        ; return (res, ev_binds) }
   where
     do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
 
+checkForCyclicBinds :: Bag EvBind -> TcM ()
+#ifndef DEBUG
+checkForCyclicBinds _ = return ()
+#else
+checkForCyclicBinds ev_binds
+  | null cycles 
+  = return ()
+  | null coercion_cycles
+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles
+  | otherwise
+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
+  where
+    cycles :: [[EvBind]]
+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges]
+
+    coercion_cycles = [c | c <- cycles, any is_co_bind c]
+    is_co_bind (EvBind b _) = isEqVar b
+
+    edges :: [(EvBind, EvVar, [EvVar])]
+    edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds]
+#endif       
 
 doWithInert :: InertSet -> TcS a -> TcS a 
 doWithInert inert (TcS action)
@@ -1038,13 +1113,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 +1134,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 +1370,168 @@ 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
 
-setEvBind :: EvVar -> EvTerm -> TcS ()
-setEvBind ev t
-  = do { tc_evbinds <- getTcEvBinds
-       ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t
+getEvTerm :: MaybeNew -> EvTerm
+getEvTerm (Fresh ctev) = ctEvTerm ctev
+getEvTerm (Cached tm)  = tm
 
-       ; traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr ev
-                                     , text "t  =" <+> ppr t ]
+getEvTerms :: [MaybeNew] -> [EvTerm]
+getEvTerms = map getEvTerm
 
-#ifndef DEBUG
-       ; return () }
-#else
-       ; binds <- getTcEvBindsMap
-       ; let cycle = any (reaches binds) (evVarsOfTerm 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
-                                                           , ppr (evBindMapBinds binds) ]
-               ; when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) }
-
-        reaches :: EvBindMap -> Var -> Bool 
-        -- Does this evvar reach ev? 
-        reaches ebm ev0 = go ev0
-          where go ev0
-                  | ev0 == ev = True
-                  | Just (EvBind _ evtrm) <- lookupEvBind ebm ev0
-                  = any go (evVarsOfTerm evtrm)
-                  | otherwise = False
-#endif
+freshGoals :: [MaybeNew] -> [CtEvidence]
+freshGoals mns = [ ctev | Fresh ctev <- mns ]
 
-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
+setEvBind :: EvVar -> EvTerm -> TcS ()
+setEvBind the_ev tm
+  = do { traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr the_ev
+                                     , text "tm  =" <+> ppr tm ]
+       ; tc_evbinds <- getTcEvBinds
+       ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm }
+
+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,15 @@ 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
+         WARNING: if we *do* need this stuff, we need to think again about cyclic bindings.
   = 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 +1699,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/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index b88029433b..114140c8d1 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -335,9 +335,9 @@ getInitialKinds (L _ decl)
 	    --	 data T :: *->* where { ... }
             -- with *no* tvs in the HsTyDefn
 
-    get_tvs (TyFamily    {tcdTyVars = tvs}) = tvs
-    get_tvs (ClassDecl   {tcdTyVars = tvs}) = tvs    
-    get_tvs (TyDecl      {tcdTyVars = tvs}) = tvs
+    get_tvs (TyFamily    {tcdTyVars = tvs}) = hsQTvBndrs tvs
+    get_tvs (ClassDecl   {tcdTyVars = tvs}) = hsQTvBndrs tvs    
+    get_tvs (TyDecl      {tcdTyVars = tvs}) = hsQTvBndrs tvs
     get_tvs (ForeignType {})                = []
  
 ----------------
@@ -431,17 +431,13 @@ kcConDecl new_or_data (ConDecl { con_name = name, con_qvars = ex_tvs
        ; return () }
 
 ------------------
-kcResultKind :: Maybe (HsBndrSig (LHsKind Name)) -> Kind -> TcM ()
+kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM ()
 kcResultKind Nothing res_k
   = discardResult (unifyKind res_k liftedTypeKind)
       --             type family F a 
       -- defaults to type family F a :: *
-kcResultKind (Just (HsBSig k (ss, ns))) res_k
-  = ASSERT( null ss )      -- Parser ensures that 
-                           --   type family F a :: (k :: s)
-                           -- is illegal
-    do { let kvs = map mkKindSigVar ns 
-       ; k' <- tcExtendTyVarEnv kvs (tcLHsKind k)
+kcResultKind (Just k ) res_k
+  = do { k' <- tcLHsKind k
        ; discardResult (unifyKind k' res_k) }
 \end{code}
 
@@ -727,7 +723,7 @@ tcSynFamInstDecl _ decl = pprPanic "tcSynFamInstDecl" (ppr decl)
 
 -----------------
 tcFamTyPats :: TyCon
-            -> HsBndrSig [LHsType Name] -- Patterns
+            -> HsWithBndrs [LHsType Name] -- Patterns
             -> (TcKind -> TcM ())       -- Kind checker for RHS
                                         -- result is ignored
             -> ([TKVar] -> [TcType] -> Kind -> TcM a)
@@ -743,7 +739,8 @@ tcFamTyPats :: TyCon
 -- In that case, the type variable 'a' will *already be in scope*
 -- (and, if C is poly-kinded, so will its kind parameter).
 
-tcFamTyPats fam_tc (HsBSig arg_pats (kvars, tvars)) kind_checker thing_inside
+tcFamTyPats fam_tc (HsWB { hswb_cts = arg_pats, hswb_kvs = kvars, hswb_tvs = tvars }) 
+            kind_checker thing_inside
   = do { -- A family instance must have exactly the same number of type
          -- parameters as the family declaration.  You can't write
          --     type family F a :: * -> *
@@ -756,14 +753,16 @@ tcFamTyPats fam_tc (HsBSig arg_pats (kvars, tvars)) kind_checker thing_inside
 
          -- Instantiate with meta kind vars
        ; fam_arg_kinds <- mapM (const newMetaKindVar) fam_kvs
+       ; loc <- getSrcSpanM
        ; let (arg_kinds, res_kind) 
                  = splitKindFunTysN fam_arity $
                    substKiWith fam_kvs fam_arg_kinds fam_body
+             hs_tvs = HsQTvs { hsq_kvs = kvars
+                             , hsq_tvs = userHsTyVarBndrs loc tvars }
 
          -- Kind-check and quantify
          -- See Note [Quantifying over family patterns]
-       ; typats <- tcExtendTyVarEnv (map mkKindSigVar kvars)      $
-                   tcHsTyVarBndrs (map (noLoc . UserTyVar) tvars) $ \ _ ->
+       ; typats <- tcHsTyVarBndrs hs_tvs $ \ _ ->
                    do { kind_checker res_kind
                       ; tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds }
        ; let all_args = fam_arg_kinds ++ typats
@@ -1106,10 +1105,10 @@ consUseH98Syntax _                                             = True
 conRepresentibleWithH98Syntax :: ConDecl Name -> Bool
 conRepresentibleWithH98Syntax
     (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 })
-        = null tvs && null (unLoc ctxt)
+        = null (hsQTvBndrs tvs) && null (unLoc ctxt)
 conRepresentibleWithH98Syntax
     (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) })
-        = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs)
+        = null (unLoc ctxt) && f t (hsLTyVarNames tvs)
     where -- Each type variable should be used exactly once in the
           -- result type, and the result type must just be the type
           -- constructor applied to type variables
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 0b2429842d..c44ce31f2e 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -533,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
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/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 8a158139cc..31ef9cc7ab 100644
--- a/compiler/types/FunDeps.lhs
+++ b/compiler/types/FunDeps.lhs
@@ -216,6 +216,10 @@ data Equation
 data FDEq = FDEq { fd_pos      :: Int -- We use '0' for the first position
                  , fd_ty_left  :: Type
                  , fd_ty_right :: Type }
+
+instance Outputable FDEq where
+  ppr (FDEq { fd_pos = p, fd_ty_left = tyl, fd_ty_right = tyr })
+    = parens (int p <> comma <+> ppr tyl <> comma <+> ppr tyr)
 \end{code}
 
 Given a bunch of predicates that must hold, such as
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index d6a744c7ac..2c4931a3dd 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -22,7 +22,6 @@ module TyCon(
         -- ** Constructing TyCons
         mkAlgTyCon,
         mkClassTyCon,
-        mkIParamTyCon,
         mkFunTyCon,
         mkPrimTyCon,
         mkKindTyCon,
@@ -859,11 +858,6 @@ mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> Ty
 mkClassTyCon name kind tyvars rhs clas is_rec =
   mkAlgTyCon name kind tyvars Nothing [] rhs (ClassTyCon clas) is_rec False
 
--- | Simpler specialization of 'mkAlgTyCon' for implicit paramaters
-mkIParamTyCon :: Name -> Kind -> TyVar -> AlgTyConRhs -> RecFlag -> TyCon
-mkIParamTyCon name kind tyvar rhs is_rec =
-  mkAlgTyCon name kind [tyvar] Nothing [] rhs NoParentTyCon is_rec False
-
 mkTupleTyCon :: Name
              -> Kind    -- ^ Kind of the resulting 'TyCon'
              -> Arity   -- ^ Arity of the tuple
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index e0de629da6..62cc7bbfd1 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -285,7 +285,7 @@ expandTypeSynonyms ty
       = TyConApp tc (map go tys)
     go (LitTy l)       = LitTy l
     go (TyVarTy tv)    = TyVarTy tv
-    go (AppTy t1 t2)   = AppTy (go t1) (go t2)
+    go (AppTy t1 t2)   = mkAppTy (go t1) (go t2)
     go (FunTy t1 t2)   = FunTy (go t1) (go t2)
     go (ForAllTy tv t) = ForAllTy tv (go t)
 \end{code}
@@ -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/types/Unify.lhs b/compiler/types/Unify.lhs
index 50a0fcf39a..de4f3fe865 100644
--- a/compiler/types/Unify.lhs
+++ b/compiler/types/Unify.lhs
@@ -516,36 +516,29 @@ uUnrefined subst tv1 ty2 (TyVarTy tv2)
   = uUnrefined subst tv1 ty' ty'
 
   | otherwise
-  -- So both are unrefined; next, see if the kinds force the direction
-  = case (k1_sub_k2, k2_sub_k1) of
-        (True,  True)  -> choose subst
-        (True,  False) -> bindTv subst tv2 ty1
-        (False, True)  -> bindTv subst tv1 ty2
-        (False, False) -> do
-            { subst' <- unify subst k1 k2
-            ; choose subst' }
-  where subst_kind = mkTvSubst (mkInScopeSet (tyVarsOfTypes [k1,k2])) subst
-        k1 = substTy subst_kind (tyVarKind tv1)
-        k2 = substTy subst_kind (tyVarKind tv2)
-        k1_sub_k2 = k1 `isSubKind` k2
-        k2_sub_k1 = k2 `isSubKind` k1
-        ty1 = TyVarTy tv1
-        bind subst tv ty = return $ extendVarEnv subst tv ty
-        choose subst = do
-             { b1 <- tvBindFlag tv1
-             ; b2 <- tvBindFlag tv2
-             ; case (b1, b2) of
-                 (BindMe, _)         -> bind subst tv1 ty2
-                 (Skolem, Skolem)    -> failWith (misMatch ty1 ty2)
-                 (Skolem, _)         -> bind subst tv2 ty1 }
+
+  = do {   -- So both are unrefined; unify the kinds
+       ; subst' <- unify subst (tyVarKind tv1) (tyVarKind tv2)
+
+           -- And then bind one or the other, 
+           -- depending on which is bindable
+	   -- NB: unlike TcUnify we do not have an elaborate sub-kinding 
+	   --     story.  That is relevant only during type inference, and
+           --     (I very much hope) is not relevant here.
+       ; b1 <- tvBindFlag tv1
+       ; b2 <- tvBindFlag tv2
+       ; let ty1 = TyVarTy tv1
+       ; case (b1, b2) of
+           (Skolem, Skolem) -> failWith (misMatch ty1 ty2)
+           (BindMe, _)      -> return (extendVarEnv subst' tv1 ty2)
+           (_, BindMe)      -> return (extendVarEnv subst' tv2 ty1) }
 
 uUnrefined subst tv1 ty2 ty2'	-- ty2 is not a type variable
   | tv1 `elemVarSet` niSubstTvSet subst (tyVarsOfType ty2')
   = failWith (occursCheck tv1 ty2)	-- Occurs check
-  | not (k2 `isSubKind` k1)
-  = failWith (kindMisMatch tv1 ty2)	-- Kind check
   | otherwise
-  = bindTv subst tv1 ty2		-- Bind tyvar to the synonym if poss
+  = do { subst' <- unify subst k1 k2
+       ; bindTv subst' tv1 ty2 }	-- Bind tyvar to the synonym if poss
   where
     k1 = tyVarKind tv1
     k2 = typeKind ty2'
@@ -626,13 +619,6 @@ lengthMisMatch tys1 tys2
   = sep [ptext (sLit "Can't match unequal length lists"), 
 	 nest 2 (ppr tys1), nest 2 (ppr tys2) ]
 
-kindMisMatch :: TyVar -> Type -> SDoc
-kindMisMatch tv1 t2
-  = vcat [ptext (sLit "Can't match kinds") <+> quotes (ppr (tyVarKind tv1)) <+> 
-	    ptext (sLit "and") <+> quotes (ppr (typeKind t2)),
-	  ptext (sLit "when matching") <+> quotes (ppr tv1) <+> 
-		ptext (sLit "with") <+> quotes (ppr t2)]
-
 occursCheck :: TyVar -> Type -> SDoc
 occursCheck tv ty
   = hang (ptext (sLit "Can't construct the infinite type"))
diff --git a/configure.ac b/configure.ac
index 8e3d9d2837..aeea6a4d9e 100644
--- a/configure.ac
+++ b/configure.ac
@@ -161,6 +161,10 @@ if test "$BootingFromHc" = "NO"; then
      or --with-ghc to specify a different GHC to use.])
      fi
   fi
+
+  GHC_PACKAGE_DB_FLAG=package-db
+  FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[7.5],GHC_PACKAGE_DB_FLAG=package-conf)
+  AC_SUBST(GHC_PACKAGE_DB_FLAG)
 fi;
 
 # GHC is passed to Cabal, so we need a native path
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 1d091d7e2f..b501961b4e 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -594,14 +594,38 @@
             <entry>-</entry>
           </row>
           <row>
-            <entry><option>-package-conf</option> <replaceable>file</replaceable></entry>
-            <entry>Load more packages from <replaceable>file</replaceable></entry>
+            <entry><option>-package-db</option> <replaceable>file</replaceable></entry>
+            <entry>Add <replaceable>file</replaceable> to the package db stack.</entry>
             <entry>static</entry>
             <entry>-</entry>
           </row>
           <row>
-            <entry><option>-no-user-package-conf</option></entry>
-            <entry>Don't load the user's package config file.</entry>
+            <entry><option>-clear-package-db</option></entry>
+            <entry>Clear the package db stack.</entry>
+            <entry>static</entry>
+            <entry>-</entry>
+          </row>
+          <row>
+            <entry><option>-no-global-package-db</option></entry>
+            <entry>Remove the global package db from the stack.</entry>
+            <entry>static</entry>
+            <entry>-</entry>
+          </row>
+          <row>
+            <entry><option>-global-package-db</option></entry>
+            <entry>Add the global package db to the stack.</entry>
+            <entry>static</entry>
+            <entry>-</entry>
+          </row>
+          <row>
+            <entry><option>-no-user-package-db</option></entry>
+            <entry>Remove the user's package db from the stack.</entry>
+            <entry>static</entry>
+            <entry>-</entry>
+          </row>
+          <row>
+            <entry><option>-user-package-db</option></entry>
+            <entry>Add the user's package db to the stack.</entry>
             <entry>static</entry>
             <entry>-</entry>
           </row>
diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml
index 4a3e45f2fb..d1df2d4712 100644
--- a/docs/users_guide/packages.xml
+++ b/docs/users_guide/packages.xml
@@ -408,35 +408,89 @@ _ZCMain_main_closure
       see GHC's package table by running GHC with the <option>-v</option>
       flag.</para>
 
-    <para>Package databases may overlap: for example, packages in the
-      user database will override (<emphasis>shadow</emphasis>) those
-      of the same name and version in the global database.</para>
+    <para>Package databases may overlap, and they are arranged in a stack
+      structure. Packages closer to the top of the stack will override
+      (<emphasis>shadow</emphasis>) those below them. By default, the stack
+      contains just the global and the user's package databases, in that
+      order.</para>
 
-    <para>You can control the loading of package databases using the following
-      GHC options:</para>
+    <para>You can control GHC's package database stack using the following
+      options:</para>
 
     <variablelist>
       <varlistentry>
         <term>
-          <option>-package-conf <replaceable>file</replaceable></option>
-          <indexterm><primary><option>-package-conf</option></primary></indexterm>
+          <option>-package-db <replaceable>file</replaceable></option>
+          <indexterm><primary><option>-package-db</option></primary></indexterm>
         </term>
         <listitem>
-          <para>Read in the package configuration file
-            <replaceable>file</replaceable> in addition to the system
-            default file and the user's local file.  Packages in additional
-            files read this way will override those in the global and user
-            databases.</para>
+          <para>Add the package database <replaceable>file</replaceable> on top
+              of the current stack. Packages in additional databases read this
+              way will override those in the initial stack and those in
+              previously specified databases.</para>
         </listitem>
       </varlistentry>
 
       <varlistentry>
-        <term><option>-no-user-package-conf</option>
-          <indexterm><primary><option>-no-user-package-conf</option></primary>
+        <term><option>-no-global-package-db</option>
+          <indexterm><primary><option>-no-global-package-db</option></primary>
           </indexterm>
         </term>
         <listitem>
-          <para>Prevent loading of the user's local package database.</para>
+          <para>Remove the global package database from the package database
+              stack.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term><option>-no-user-package-db</option>
+          <indexterm><primary><option>-no-user-package-db</option></primary>
+          </indexterm>
+        </term>
+        <listitem>
+          <para>Prevent loading of the user's local package database in the
+              initial stack.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term><option>-clear-package-db</option>
+          <indexterm><primary><option>-clear-package-db</option></primary>
+          </indexterm>
+        </term>
+        <listitem>
+            <para>Reset the current package database stack. This option removes
+                every previously specified package database (including those
+                read from the <literal>GHC_PACKAGE_PATH</literal> environment
+                variable) from the package database stack.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term><option>-global-package-db</option>
+          <indexterm><primary><option>-global-package-db</option></primary>
+          </indexterm>
+        </term>
+        <listitem>
+          <para>Add the global package database on top of the current stack.
+            This option can be used after
+            <literal>-no-global-package-db</literal> to specify the position in
+            the stack where the global package database should be
+            loaded.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term><option>-user-package-db</option>
+          <indexterm><primary><option>-user-package-db</option></primary>
+          </indexterm>
+        </term>
+        <listitem>
+          <para>Add the user's package database on top of the current stack.
+            This option can be used after
+            <literal>-no-user-package-db</literal> to specify the position in
+            the stack where the user's package database should be
+            loaded.</para>
         </listitem>
       </varlistentry>
     </variablelist>
@@ -456,11 +510,13 @@ _ZCMain_main_closure
         packages.</para>
 
       <para>If <literal>GHC_PACKAGE_PATH</literal> ends in a separator, then
-        the default user and system package databases are appended, in that
-        order. e.g. to augment the usual set of packages with a database of
-        your own, you could say (on Unix):
-<screen>
-$ export GHC_PACKAGE_PATH=$HOME/.my-ghc-packages.conf:</screen>
+        the default package database stack (i.e. the user and global
+        package databases, in that order) is appended. For example, to augment
+        the usual set of packages with a database of your own, you could say
+        (on Unix):
+
+        <screen> $ export GHC_PACKAGE_PATH=$HOME/.my-ghc-packages.conf:</screen>
+
         (use <literal>;</literal> instead of <literal>:</literal> on
         Windows).</para>
 
@@ -601,12 +657,12 @@ haskell98-1.0.1.0
       <literal>ghc-pkg</literal> knows about can be modified using the
       <literal>GHC_PACKAGE_PATH</literal> environment variable (see <xref
         linkend="ghc-package-path" />, and using
-        <literal>--package-conf</literal> options on the
+        <literal>--package-db</literal> options on the
         <literal>ghc-pkg</literal> command line.</para>
 
     <para>When asked to modify a database, <literal>ghc-pkg</literal> modifies
       the global database by default.  Specifying <option>--user</option>
-      causes it to act on the user database, or <option>--package-conf</option>
+      causes it to act on the user database, or <option>--package-db</option>
       can be used to act on another database entirely.  When multiple of these
       options are given, the rightmost one is used as the database to act
       upon.</para>
@@ -614,7 +670,7 @@ haskell98-1.0.1.0
    <para>Commands that query the package database (list, latest,
      describe, field, dot) operate on the list of databases specified by
      the flags <option>--user</option>, <option>--global</option>, and
-     <option>--package-conf</option>.  If none of these flags are
+     <option>--package-db</option>.  If none of these flags are
      given, the default is <option>--global</option>
      <option>--user</option>.</para>
 
@@ -888,8 +944,8 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf
           </indexterm>
         </term>
         <term>
-          <option>-package-conf</option> <replaceable>file</replaceable>
-          <indexterm><primary><option>-package-conf</option></primary>
+          <option>-package-db</option> <replaceable>file</replaceable>
+          <indexterm><primary><option>-package-db</option></primary>
           </indexterm>
         </term>
         <listitem>
@@ -898,7 +954,7 @@ ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf
             also be the database modified by a <literal>register</literal>,
             <literal>unregister</literal>, <literal>expose</literal> or
             <literal>hide</literal> command, unless it is overridden by a later
-            <option>--package-conf</option>, <option>--user</option> or
+            <option>--package-db</option>, <option>--user</option> or
             <option>--global</option> option.</para>
         </listitem>
       </varlistentry>
diff --git a/docs/users_guide/runghc.xml b/docs/users_guide/runghc.xml
index 0681f00851..7d61f83ee1 100644
--- a/docs/users_guide/runghc.xml
+++ b/docs/users_guide/runghc.xml
@@ -32,7 +32,7 @@ runghc [runghc flags] [GHC flags] module [program args]
     with a dash then you need to prefix it with
     <literal>--ghc-arg=</literal> or runghc will think that it is the
     program to run, e.g.
-    <literal>runghc -package-conf --ghc-arg=foo.conf Main.hs</literal>.
+    <literal>runghc -package-db --ghc-arg=foo.conf Main.hs</literal>.
     </para>
 
   </sect1>
diff --git a/ghc.mk b/ghc.mk
index 195310bef6..a23171caa7 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -899,7 +899,7 @@ install_packages: rts/package.conf.install
 	$(call INSTALL_DIR,"$(DESTDIR)$(topdir)")
 	$(call removeTrees,"$(INSTALLED_PACKAGE_CONF)")
 	$(call INSTALL_DIR,"$(INSTALLED_PACKAGE_CONF)")
-	"$(INSTALLED_GHC_PKG_REAL)" --force --global-conf "$(INSTALLED_PACKAGE_CONF)" update rts/package.conf.install
+	"$(INSTALLED_GHC_PKG_REAL)" --force --global-package-db "$(INSTALLED_PACKAGE_CONF)" update rts/package.conf.install
 	$(foreach p, $(INSTALLED_PKG_DIRS),                           \
 	    $(call make-command,                                      \
                    CROSS_COMPILE="$(CrossCompilePrefix)"              \
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 1a80b49639..efafd25d23 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -993,7 +993,7 @@ pprInfo pefas (thing, fixity, insts)
   where
     show_fixity fix
         | fix == GHC.defaultFixity = empty
-        | otherwise                = ppr fix <+> ppr (GHC.getName thing)
+        | otherwise                = ppr fix <+> pprInfixName (GHC.getName thing)
 
 -----------------------------------------------------------------------------
 -- :main
diff --git a/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs b/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs
index 242b7c02d1..7a254b7ac6 100644
--- a/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs
+++ b/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs
@@ -136,7 +136,8 @@ instance Binary License where
   put PublicDomain         = do putWord8 5
   put AllRightsReserved    = do putWord8 6
   put OtherLicense         = do putWord8 7
-  put (UnknownLicense str) = do putWord8 8; put str
+  put (Apache v)           = do putWord8 8; put v
+  put (UnknownLicense str) = do putWord8 9; put str
 
   get = do
     n <- getWord8
@@ -149,6 +150,7 @@ instance Binary License where
       5 -> return PublicDomain
       6 -> return AllRightsReserved
       7 -> return OtherLicense
+      8 -> do v <- get; return (Apache v)
       _ -> do str <- get; return (UnknownLicense str)
 
 instance Binary Version where
diff --git a/mk/config.mk.in b/mk/config.mk.in
index b998946239..1cf8685383 100644
--- a/mk/config.mk.in
+++ b/mk/config.mk.in
@@ -543,6 +543,8 @@ compiler/cmm/Bitmap_HC_OPTS += -ffull-laziness
 # for some unknown reason, so turn full-laziness back on for this module.
 endif
 
+GHC_PACKAGE_DB_FLAG = @GHC_PACKAGE_DB_FLAG@
+
 #-----------------------------------------------------------------------------
 # C compiler
 #
diff --git a/rules/distdir-way-opts.mk b/rules/distdir-way-opts.mk
index dcbd9cb8a6..bbd37d1ee1 100644
--- a/rules/distdir-way-opts.mk
+++ b/rules/distdir-way-opts.mk
@@ -61,7 +61,7 @@ define distdir-way-opts # args: $1 = dir, $2 = distdir, $3 = way, $4 = stage
 #   
 #  $1_$2_EXTRA_HC_OPTS   GHC options for this dir/distdir  mk/build.mk
 #   
-#  $1_$2_HC_PKGCONF      -package-conf flag if necessary   rules/package-config.mk
+#  $1_$2_HC_PKGCONF      -package-db flag if necessary   rules/package-config.mk
 #   
 #  $1_$2_HS_SRC_DIRS     dirs relative to $1 containing    $1/$2/package-data.mk
 #                        source files   
diff --git a/rules/package-config.mk b/rules/package-config.mk
index e0c9757862..1173e5f025 100644
--- a/rules/package-config.mk
+++ b/rules/package-config.mk
@@ -34,10 +34,10 @@ $1_$2_HC_MK_DEPEND = $$($1_$2_HC)
 # on cygwin we get a dep on c:/ghc/..., and make gets confused by the :
 $1_$2_HC_MK_DEPEND_DEP =
 $1_$2_HC_DEP =
-$1_$2_HC_PKGCONF = -package-conf $$(BOOTSTRAPPING_CONF)
-$1_$2_GHC_PKG_OPTS = --package-conf=$$(BOOTSTRAPPING_CONF)
+$1_$2_HC_PKGCONF = -$(GHC_PACKAGE_DB_FLAG) $$(BOOTSTRAPPING_CONF)
+$1_$2_GHC_PKG_OPTS = --$(GHC_PACKAGE_DB_FLAG)=$$(BOOTSTRAPPING_CONF)
 $1_$2_CONFIGURE_OPTS += --package-db=$$(TOP)/$$(BOOTSTRAPPING_CONF)
-$1_$2_MORE_HC_OPTS += -no-user-package-conf
+$1_$2_MORE_HC_OPTS += -no-user-$(GHC_PACKAGE_DB_FLAG)
 $1_$2_MORE_HC_OPTS += -rtsopts
 else
 $1_$2_HC_PKGCONF = 
@@ -51,7 +51,7 @@ $1_$2_GHC_PKG_OPTS =
 $1_$2_HC_MK_DEPEND = $$(GHC_STAGE1)
 $1_$2_HC_MK_DEPEND_DEP = $$($1_$2_HC_MK_DEPEND)
 $1_$2_HC_DEP = $$($1_$2_HC)
-$1_$2_MORE_HC_OPTS += -no-user-package-conf
+$1_$2_MORE_HC_OPTS += -no-user-package-db
 $1_$2_MORE_HC_OPTS += -rtsopts
 endif
 
diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs
index c24f127422..0f11eea497 100644
--- a/utils/ghc-cabal/Main.hs
+++ b/utils/ghc-cabal/Main.hs
@@ -190,7 +190,7 @@ doInstall ghc ghcpkg strip topdir directory distDir
                     programPostConf = \_ _ -> return ["-B" ++ topdir],
                     programFindLocation = \_ -> return (Just ghc) }
                 ghcPkgProgram' = ghcPkgProgram {
-                    programPostConf = \_ _ -> return $ ["--global-conf", ghcpkgconf]
+                    programPostConf = \_ _ -> return $ ["--global-package-db", ghcpkgconf]
                                                     ++ ["--force" | not (null myDestDir) ],
                     programFindLocation = \_ -> return (Just ghcpkg) }
                 stripProgram' = stripProgram {
diff --git a/utils/ghc-cabal/ghc.mk b/utils/ghc-cabal/ghc.mk
index 3ee2b13fa5..0a3e920e7a 100644
--- a/utils/ghc-cabal/ghc.mk
+++ b/utils/ghc-cabal/ghc.mk
@@ -27,7 +27,7 @@ $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/C
 
 $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(GHC_CABAL_DIR)/Main.hs $(TOUCH_DEP) | $$(dir $$@)/. bootstrapping/.
 	"$(GHC)" $(SRC_HC_OPTS) --make $(GHC_CABAL_DIR)/Main.hs -o $@ \
-	       -no-user-package-conf \
+	       -no-user-$(GHC_PACKAGE_DB_FLAG) \
 	       -Wall \
 	       -DCABAL_VERSION=$(CABAL_VERSION) \
 	       -odir  bootstrapping \
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index e29301d933..e63139e997 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -119,11 +119,11 @@ flags = [
         "use the current user's package database",
   Option [] ["global"] (NoArg FlagGlobal)
         "use the global package database",
-  Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
+  Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE")
         "use the specified package config file",
-  Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
+  Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "FILE")
         "location of the global package config",
-  Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
+  Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
         "never read the user package database",
   Option [] ["force"] (NoArg FlagForce)
          "ignore missing dependencies, directories, and libraries",
@@ -177,8 +177,8 @@ usageHeader prog = substProg prog $
   "  $p init {path}\n" ++
   "    Create and initialise a package database at the location {path}.\n" ++
   "    Packages can be registered in the new database using the register\n" ++
-  "    command with --package-conf={path}.  To use the new database with GHC,\n" ++
-  "    use GHC's -package-conf flag.\n" ++
+  "    command with --package-db={path}.  To use the new database with GHC,\n" ++
+  "    use GHC's -package-db flag.\n" ++
   "\n" ++
   "  $p register {filename | -}\n" ++
   "    Register the package using the specified installed package\n" ++
@@ -247,7 +247,7 @@ usageHeader prog = substProg prog $
   "    Regenerate the package database cache.  This command should only be\n" ++
   "    necessary if you added a package to the database by dropping a file\n" ++
   "    into the database directory manually.  By default, the global DB\n" ++
-  "    is recached; to recache a different DB use --user or --package-conf\n" ++
+  "    is recached; to recache a different DB use --user or --package-db\n" ++
   "    as appropriate.\n" ++
   "\n" ++
   " Substring matching is supported for {module} in find-module and\n" ++
@@ -257,13 +257,13 @@ usageHeader prog = substProg prog $
   "  When asked to modify a database (register, unregister, update,\n"++
   "  hide, expose, and also check), ghc-pkg modifies the global database by\n"++
   "  default.  Specifying --user causes it to act on the user database,\n"++
-  "  or --package-conf can be used to act on another database\n"++
+  "  or --package-db can be used to act on another database\n"++
   "  entirely. When multiple of these options are given, the rightmost\n"++
   "  one is used as the database to act upon.\n"++
   "\n"++
   "  Commands that query the package database (list, tree, latest, describe,\n"++
   "  field) operate on the list of databases specified by the flags\n"++
-  "  --user, --global, and --package-conf.  If none of these flags are\n"++
+  "  --user, --global, and --package-db.  If none of these flags are\n"++
   "  given, the default is --global --user.\n"++
   "\n" ++
   " The following optional flags are also accepted:\n"
@@ -471,9 +471,9 @@ getPkgDatabases :: Verbosity
 getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
   -- first we determine the location of the global package config.  On Windows,
   -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-  -- location is passed to the binary using the --global-config flag by the
+  -- location is passed to the binary using the --global-package-db flag by the
   -- wrapper script.
-  let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
+  let err_msg = "missing --global-package-db option, location of global package database unknown\n"
   global_conf <-
      case [ f | FlagGlobalConfig f <- my_flags ] of
         [] -> do mb_dir <- getLibDir
diff --git a/utils/ghc-pkg/ghc-pkg.wrapper b/utils/ghc-pkg/ghc-pkg.wrapper
index fad4bdfca0..3a14de1e22 100644
--- a/utils/ghc-pkg/ghc-pkg.wrapper
+++ b/utils/ghc-pkg/ghc-pkg.wrapper
@@ -1,5 +1,5 @@
 #!/bin/sh
 
 PKGCONF="$topdir/package.conf.d"
-exec "$executablename" --global-conf "$PKGCONF" ${1+"$@"}
+exec "$executablename" --global-package-db "$PKGCONF" ${1+"$@"}
 
diff --git a/utils/ghc-pkg/ghc.mk b/utils/ghc-pkg/ghc.mk
index 4f4967e07f..8ec3fd0097 100644
--- a/utils/ghc-pkg/ghc.mk
+++ b/utils/ghc-pkg/ghc.mk
@@ -24,7 +24,7 @@ else
 	$(call removeFiles,$@)
 	echo "#!/bin/sh" >>$@
 	echo "PKGCONF=$(TOP)/$(INPLACE_PACKAGE_CONF)" >>$@
-	echo '$(TOP)/$< --global-conf $$PKGCONF $${1+"$$@"}' >> $@
+	echo '$(TOP)/$< --global-package-db $$PKGCONF $${1+"$$@"}' >> $@
 	chmod +x $@
 endif
 
@@ -38,7 +38,7 @@ else
 	$(call removeFiles,$@)
 	echo "#!/bin/sh" >>$@
 	echo "PKGCONF=$(TOP)/$(INPLACE_PACKAGE_CONF)" >>$@
-	echo '$(TOP)/$< --global-conf $$PKGCONF $${1+"$$@"}' >> $@
+	echo '$(TOP)/$< --global-package-db $$PKGCONF $${1+"$$@"}' >> $@
 	chmod +x $@
 endif
 
@@ -53,7 +53,7 @@ endif
 #
 utils/ghc-pkg/dist/build/tmp/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/Version.hs | bootstrapping/. $$(dir $$@)/. $(GHC_CABAL_INPLACE) 
 	"$(GHC)" $(SRC_HC_OPTS) --make utils/ghc-pkg/Main.hs -o $@ \
-	       -no-user-package-conf \
+	       -no-user-$(GHC_PACKAGE_DB_FLAG) \
 	       -Wall -fno-warn-unused-imports -fno-warn-warnings-deprecations \
 	       $(SRC_HC_WARNING_OPTS) \
 	       -DCABAL_VERSION=$(CABAL_VERSION) \