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

32 files changed, 941 insertions, 707 deletions

diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index 1692520858..8e31fef8ea 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -85,6 +85,8 @@ import FastTypes
 import FastString
 import Outputable
 
+import StaticFlags ( opt_SuppressVarKinds )
+
 import Data.Data
 \end{code}
 
@@ -211,7 +213,8 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
 \begin{code}
 instance Outputable Var where
   ppr var = ifPprDebug (text "(") <+> ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
-            <+> ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
+            <+> if (not opt_SuppressVarKinds) then ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
+                else empty
 
 ppr_debug :: Var -> SDoc
 ppr_debug (TyVar {})                           = ptext (sLit "tv")
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index a2ffd18649..4f8a061bdd 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -254,7 +254,7 @@ pprStmt platform stmt = case stmt of
 pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
 pprCFunType ppr_fn cconv ress args
   = res_type ress <+>
-    parens (text (ccallConvAttribute cconv) <>  ppr_fn) <>
+    parens (ccallConvAttribute cconv <> ppr_fn) <>
     parens (commafy (map arg_type args))
   where
         res_type [] = ptext (sLit "void")
@@ -845,6 +845,7 @@ pprCall platform ppr_fn cconv results args _
 -- change in the future...
 is_cishCC :: CCallConv -> Bool
 is_cishCC CCallConv    = True
+is_cishCC CApiConv     = True
 is_cishCC StdCallConv  = True
 is_cishCC CmmCallConv  = False
 is_cishCC PrimCallConv = False
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index 295d76344a..d96e9f8cfc 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -6,13 +6,6 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module CgForeignCall (
   cgForeignCall,
   emitForeignCall,
@@ -50,32 +43,32 @@ import Control.Monad
 -- Code generation for Foreign Calls
 
 cgForeignCall
-	:: [HintedCmmFormal]	-- where to put the results
-	-> ForeignCall		-- the op
-	-> [StgArg]		-- arguments
-	-> StgLiveVars	-- live vars, in case we need to save them
-	-> Code
+        :: [HintedCmmFormal]    -- where to put the results
+        -> ForeignCall          -- the op
+        -> [StgArg]             -- arguments
+        -> StgLiveVars  -- live vars, in case we need to save them
+        -> Code
 cgForeignCall results fcall stg_args live
-  = do 
+  = do
   reps_n_amodes <- getArgAmodes stg_args
   let
-	-- Get the *non-void* args, and jiggle them with shimForeignCall
-	arg_exprs = [ shimForeignCallArg stg_arg expr 
-	  	    | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, 
-	               nonVoidArg rep]
+        -- Get the *non-void* args, and jiggle them with shimForeignCall
+        arg_exprs = [ shimForeignCallArg stg_arg expr
+                    | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
+                       nonVoidArg rep]
 
-	arg_hints = zipWith CmmHinted
+        arg_hints = zipWith CmmHinted
                       arg_exprs (map (typeForeignHint.stgArgType) stg_args)
   -- in
   emitForeignCall results fcall arg_hints live
 
 
 emitForeignCall
-	:: [HintedCmmFormal]	-- where to put the results
-	-> ForeignCall		-- the op
-	-> [CmmHinted CmmExpr] -- arguments
-	-> StgLiveVars	-- live vars, in case we need to save them
-	-> Code
+        :: [HintedCmmFormal]    -- where to put the results
+        -> ForeignCall          -- the op
+        -> [CmmHinted CmmExpr] -- arguments
+        -> StgLiveVars  -- live vars, in case we need to save them
+        -> Code
 
 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
   = do vols <- getVolatileRegs live
@@ -84,34 +77,34 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
          (CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn
   where
       (call_args, cmm_target)
-	= case target of
-	   -- If the packageId is Nothing then the label is taken to be in the
-	   --	package currently being compiled.
-	   StaticTarget lbl mPkgId
-	    -> let labelSource 
-	    		= case mPkgId of
-				Nothing		-> ForeignLabelInThisPackage
-				Just pkgId	-> ForeignLabelInPackage pkgId
-	       in ( args
-	          , CmmLit (CmmLabel 
-			   	(mkForeignLabel lbl call_size labelSource IsFunction)))
-
-	   -- A label imported with "foreign import ccall "dynamic" ..."
-	   --	Note: "dynamic" here doesn't mean "dynamic library".
-	   --	Read the FFI spec for details.
-	   DynamicTarget    ->  case args of
-	                        (CmmHinted fn _):rest -> (rest, fn)
-	                        [] -> panic "emitForeignCall: DynamicTarget []"
-
-	-- in the stdcall calling convention, the symbol needs @size appended
-	-- to it, where size is the total number of bytes of arguments.  We
-	-- attach this info to the CLabel here, and the CLabel pretty printer
-	-- will generate the suffix when the label is printed.
+        = case target of
+           -- If the packageId is Nothing then the label is taken to be in the
+           --   package currently being compiled.
+           StaticTarget lbl mPkgId
+            -> let labelSource
+                        = case mPkgId of
+                                Nothing         -> ForeignLabelInThisPackage
+                                Just pkgId      -> ForeignLabelInPackage pkgId
+               in ( args
+                  , CmmLit (CmmLabel
+                                (mkForeignLabel lbl call_size labelSource IsFunction)))
+
+           -- A label imported with "foreign import ccall "dynamic" ..."
+           --   Note: "dynamic" here doesn't mean "dynamic library".
+           --   Read the FFI spec for details.
+           DynamicTarget    ->  case args of
+                                (CmmHinted fn _):rest -> (rest, fn)
+                                [] -> panic "emitForeignCall: DynamicTarget []"
+
+        -- in the stdcall calling convention, the symbol needs @size appended
+        -- to it, where size is the total number of bytes of arguments.  We
+        -- attach this info to the CLabel here, and the CLabel pretty printer
+        -- will generate the suffix when the label is printed.
       call_size
-	| StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args))
-	| otherwise            = Nothing
+        | StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args))
+        | otherwise            = Nothing
 
-	-- ToDo: this might not be correct for 64-bit API
+        -- ToDo: this might not be correct for 64-bit API
       arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE
 
 
@@ -120,14 +113,14 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
 -- which should be used instead of this (the equivalent emitForeignCall
 -- is not presently exported.)
 emitForeignCall'
-	:: Safety
-	-> [HintedCmmFormal]	-- where to put the results
-	-> CmmCallTarget	-- the op
-	-> [CmmHinted CmmExpr] -- arguments
-	-> Maybe [GlobalReg]	-- live vars, in case we need to save them
+        :: Safety
+        -> [HintedCmmFormal]    -- where to put the results
+        -> CmmCallTarget        -- the op
+        -> [CmmHinted CmmExpr] -- arguments
+        -> Maybe [GlobalReg]    -- live vars, in case we need to save them
         -> C_SRT                -- the SRT of the calls continuation
         -> CmmReturnInfo
-	-> Code
+        -> Code
 emitForeignCall' safety results target args vols _srt ret
   | not (playSafe safety) = do
     temp_args <- load_args_into_temps args
@@ -152,16 +145,16 @@ emitForeignCall' safety results target args vols _srt ret
     -- Once that happens, this function will just emit a (CmmSafe srt) call,
     -- and the CPS will be the one to convert that
     -- to this sequence of three CmmUnsafe calls.
-    stmtC (CmmCall (CmmCallee suspendThread CCallConv) 
-			[ CmmHinted id AddrHint ]
-			[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
-			, CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
-			CmmUnsafe ret)
+    stmtC (CmmCall (CmmCallee suspendThread CCallConv)
+                        [ CmmHinted id AddrHint ]
+                        [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
+                        , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
+                        CmmUnsafe ret)
     stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
-    stmtC (CmmCall (CmmCallee resumeThread CCallConv) 
-			[ CmmHinted new_base AddrHint ]
-			[ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
-			CmmUnsafe ret)
+    stmtC (CmmCall (CmmCallee resumeThread CCallConv)
+                        [ CmmHinted new_base AddrHint ]
+                        [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
+                        CmmUnsafe ret)
     -- Assign the result to BaseReg: we
     -- might now have a different Capability!
     stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
@@ -183,11 +176,11 @@ resumeThread  = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThre
 load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr]
 load_args_into_temps = mapM arg_assign_temp
   where arg_assign_temp (CmmHinted e hint) = do
-	   tmp <- maybe_assign_temp e
-	   return (CmmHinted tmp hint)
-	
+           tmp <- maybe_assign_temp e
+           return (CmmHinted tmp hint)
+
 load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget
-load_target_into_temp (CmmCallee expr conv) = do 
+load_target_into_temp (CmmCallee expr conv) = do
   tmp <- maybe_assign_temp expr
   return (CmmCallee tmp conv)
 load_target_into_temp other_target =
@@ -196,13 +189,13 @@ load_target_into_temp other_target =
 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
 maybe_assign_temp e
   | hasNoGlobalRegs e = return e
-  | otherwise          = do 
-	-- don't use assignTemp, it uses its own notion of "trivial"
-	-- expressions, which are wrong here.
+  | otherwise          = do
+        -- don't use assignTemp, it uses its own notion of "trivial"
+        -- expressions, which are wrong here.
         -- this is a NonPtr because it only duplicates an existing
-	reg <- newTemp (cmmExprType e) --TODO FIXME NOW
-	stmtC (CmmAssign (CmmLocal reg) e)
-	return (CmmReg (CmmLocal reg))
+        reg <- newTemp (cmmExprType e) --TODO FIXME NOW
+        stmtC (CmmAssign (CmmLocal reg) e)
+        return (CmmReg (CmmLocal reg))
 
 -- -----------------------------------------------------------------------------
 -- Save/restore the thread state in the TSO
@@ -218,7 +211,7 @@ emitSaveThreadState = do
   emitCloseNursery
   -- and save the current cost centre stack in the TSO when profiling:
   when opt_SccProfilingOn $
-	stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
+        stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 
    -- CurrentNursery->free = Hp+1;
 emitCloseNursery :: Code
@@ -238,7 +231,7 @@ emitLoadThreadState = do
                               bWord),
         -- SpLim = stack->stack + RESERVED_STACK_WORDS;
         CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
-			            rESERVED_STACK_WORDS),
+                                    rESERVED_STACK_WORDS),
         -- HpAlloc = 0;
         --   HpAlloc is assumed to be set to non-zero only by a failed
         --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
@@ -247,28 +240,28 @@ emitLoadThreadState = do
   emitOpenNursery
   -- and load the current cost centre stack from the TSO when profiling:
   when opt_SccProfilingOn $
-	stmtC (CmmStore curCCSAddr 
+        stmtC (CmmStore curCCSAddr
                 (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
 
 emitOpenNursery :: Code
 emitOpenNursery = stmtsC [
         -- Hp = CurrentNursery->free - 1;
-	CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
-
-        -- HpLim = CurrentNursery->start + 
-	--		CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-	CmmAssign hpLim
-	    (cmmOffsetExpr
-		(CmmLoad nursery_bdescr_start bWord)
-		(cmmOffset
-		  (CmmMachOp mo_wordMul [
-		    CmmMachOp (MO_SS_Conv W32 wordWidth)
-		      [CmmLoad nursery_bdescr_blocks b32],
-		    CmmLit (mkIntCLit bLOCK_SIZE)
-		   ])
-		  (-1)
-		)
-	    )
+        CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (-1)),
+
+        -- HpLim = CurrentNursery->start +
+        --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+        CmmAssign hpLim
+            (cmmOffsetExpr
+                (CmmLoad nursery_bdescr_start bWord)
+                (cmmOffset
+                  (CmmMachOp mo_wordMul [
+                    CmmMachOp (MO_SS_Conv W32 wordWidth)
+                      [CmmLoad nursery_bdescr_blocks b32],
+                    CmmLit (mkIntCLit bLOCK_SIZE)
+                   ])
+                  (-1)
+                )
+            )
    ]
 
 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
@@ -286,19 +279,19 @@ closureField :: ByteOff -> ByteOff
 closureField off = off + fixedHdrSize * wORD_SIZE
 
 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
-stgSp		  = CmmReg sp
-stgHp		  = CmmReg hp
-stgCurrentTSO	  = CmmReg currentTSO
+stgSp             = CmmReg sp
+stgHp             = CmmReg hp
+stgCurrentTSO     = CmmReg currentTSO
 stgCurrentNursery = CmmReg currentNursery
 
 sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
-sp		  = CmmGlobal Sp
-spLim		  = CmmGlobal SpLim
-hp		  = CmmGlobal Hp
-hpLim		  = CmmGlobal HpLim
-currentTSO	  = CmmGlobal CurrentTSO
-currentNursery 	  = CmmGlobal CurrentNursery
-hpAlloc 	  = CmmGlobal HpAlloc
+sp                = CmmGlobal Sp
+spLim             = CmmGlobal SpLim
+hp                = CmmGlobal Hp
+hpLim             = CmmGlobal HpLim
+currentTSO        = CmmGlobal CurrentTSO
+currentNursery    = CmmGlobal CurrentNursery
+hpAlloc           = CmmGlobal HpAlloc
 
 -- -----------------------------------------------------------------------------
 -- For certain types passed to foreign calls, we adjust the actual
@@ -308,12 +301,12 @@ hpAlloc 	  = CmmGlobal HpAlloc
 shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
 shimForeignCallArg arg expr
   | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
-	= cmmOffsetB expr arrPtrsHdrSize
+        = cmmOffsetB expr arrPtrsHdrSize
 
   | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
-	= cmmOffsetB expr arrWordsHdrSize
+        = cmmOffsetB expr arrWordsHdrSize
 
   | otherwise = expr
-  where	
-	-- should be a tycon app, since this is a foreign call
-	tycon = tyConAppTyCon (repType (stgArgType arg))
+  where
+        -- should be a tycon app, since this is a foreign call
+        tycon = tyConAppTyCon (repType (stgArgType arg))
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index f07fd6c6bc..78aabd82ce 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -6,13 +6,6 @@
 --
 -----------------------------------------------------------------------------
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module StgCmmForeign (
   cgForeignCall, loadThreadState, saveThreadState,
   emitPrimCall, emitCCall,
@@ -52,63 +45,63 @@ import Control.Monad
 -- Code generation for Foreign Calls
 -----------------------------------------------------------------------------
 
-cgForeignCall :: [LocalReg]		-- r1,r2  where to put the results
-	      -> [ForeignHint]
-	      -> ForeignCall		-- the op
-	      -> [StgArg]		-- x,y	  arguments
-	      -> FCode ()
+cgForeignCall :: [LocalReg]             -- r1,r2  where to put the results
+              -> [ForeignHint]
+              -> ForeignCall            -- the op
+              -> [StgArg]               -- x,y    arguments
+              -> FCode ()
 -- Emits code for an unsafe foreign call:      r1, r2 = foo( x, y, z )
 
 cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
-  = do	{ cmm_args <- getFCallArgs stg_args
+  = do  { cmm_args <- getFCallArgs stg_args
         ; let ((call_args, arg_hints), cmm_target)
                 = case target of
-                   StaticTarget lbl mPkgId 
-		     -> let labelSource
-				= case mPkgId of
-					Nothing		-> ForeignLabelInThisPackage
-					Just pkgId	-> ForeignLabelInPackage pkgId
-			    size	= call_size cmm_args
-			in  ( unzip cmm_args
-			    , CmmLit (CmmLabel 
-					(mkForeignLabel lbl size labelSource IsFunction)))
- 
+                   StaticTarget lbl mPkgId
+                     -> let labelSource
+                                = case mPkgId of
+                                        Nothing         -> ForeignLabelInThisPackage
+                                        Just pkgId      -> ForeignLabelInPackage pkgId
+                            size        = call_size cmm_args
+                        in  ( unzip cmm_args
+                            , CmmLit (CmmLabel
+                                        (mkForeignLabel lbl size labelSource IsFunction)))
+
                    DynamicTarget    ->  case cmm_args of
                                            (fn,_):rest -> (unzip rest, fn)
                                            [] -> panic "cgForeignCall []"
               fc = ForeignConvention cconv arg_hints result_hints
               call_target = ForeignTarget cmm_target fc
-        
-        ; srt <- getSRTInfo NoSRT        -- SLPJ: Not sure what SRT 
+
+        ; srt <- getSRTInfo NoSRT        -- SLPJ: Not sure what SRT
                                         -- is right here
                                         -- JD: Does it matter in the new codegen?
         ; emitForeignCall safety results call_target call_args srt CmmMayReturn }
   where
-	-- in the stdcall calling convention, the symbol needs @size appended
-	-- to it, where size is the total number of bytes of arguments.  We
-	-- attach this info to the CLabel here, and the CLabel pretty printer
-	-- will generate the suffix when the label is printed.
+        -- in the stdcall calling convention, the symbol needs @size appended
+        -- to it, where size is the total number of bytes of arguments.  We
+        -- attach this info to the CLabel here, and the CLabel pretty printer
+        -- will generate the suffix when the label is printed.
       call_size args
-	| StdCallConv <- cconv = Just (sum (map arg_size args))
-	| otherwise            = Nothing
+        | StdCallConv <- cconv = Just (sum (map arg_size args))
+        | otherwise            = Nothing
 
-	-- ToDo: this might not be correct for 64-bit API
+        -- ToDo: this might not be correct for 64-bit API
       arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
 
 emitCCall :: [(CmmFormal,ForeignHint)]
-	  -> CmmExpr 
-	  -> [(CmmActual,ForeignHint)]
-	  -> FCode ()
+          -> CmmExpr
+          -> [(CmmActual,ForeignHint)]
+          -> FCode ()
 emitCCall hinted_results fn hinted_args
   = emitForeignCall PlayRisky results target args
-	            NoC_SRT -- No SRT b/c we PlayRisky
-              	    CmmMayReturn
+                    NoC_SRT -- No SRT b/c we PlayRisky
+                    CmmMayReturn
   where
     (args, arg_hints) = unzip hinted_args
     (results, result_hints) = unzip hinted_results
     target = ForeignTarget fn fc
     fc = ForeignConvention CCallConv arg_hints result_hints
-    
+
 
 emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
 emitPrimCall res op args
@@ -138,7 +131,7 @@ emitForeignCall safety results target args _srt _ret
 
 
 {-
---	THINK ABOUT THIS (used to happen)
+--      THINK ABOUT THIS (used to happen)
 -- we might need to load arguments into temporaries before
 -- making the call, because certain global registers might
 -- overlap with registers that the C calling convention uses
@@ -148,12 +141,12 @@ emitForeignCall safety results target args _srt _ret
 -- it's easier to generate the temporaries here.
 load_args_into_temps = mapM arg_assign_temp
   where arg_assign_temp (e,hint) = do
-	   tmp <- maybe_assign_temp e
-	   return (tmp,hint)
+           tmp <- maybe_assign_temp e
+           return (tmp,hint)
 -}
-	
+
 load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
-load_target_into_temp (ForeignTarget expr conv) = do 
+load_target_into_temp (ForeignTarget expr conv) = do
   tmp <- maybe_assign_temp expr
   return (ForeignTarget tmp conv)
 load_target_into_temp other_target@(PrimTarget _) =
@@ -162,13 +155,13 @@ load_target_into_temp other_target@(PrimTarget _) =
 maybe_assign_temp :: CmmExpr -> FCode CmmExpr
 maybe_assign_temp e
   | hasNoGlobalRegs e = return e
-  | otherwise         = do 
-	-- don't use assignTemp, it uses its own notion of "trivial"
-	-- expressions, which are wrong here.
+  | otherwise         = do
+        -- don't use assignTemp, it uses its own notion of "trivial"
+        -- expressions, which are wrong here.
         -- this is a NonPtr because it only duplicates an existing
-	reg <- newTemp (cmmExprType e) --TODO FIXME NOW
-	emit (mkAssign (CmmLocal reg) e)
-	return (CmmReg (CmmLocal reg))
+        reg <- newTemp (cmmExprType e) --TODO FIXME NOW
+        emit (mkAssign (CmmLocal reg) e)
+        return (CmmReg (CmmLocal reg))
 
 -- -----------------------------------------------------------------------------
 -- Save/restore the thread state in the TSO
@@ -183,7 +176,7 @@ saveThreadState =
   <*> closeNursery
   -- and save the current cost centre stack in the TSO when profiling:
   <*> if opt_SccProfilingOn then
-	mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
+        mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
       else mkNop
 
 emitSaveThreadState :: BlockId -> FCode ()
@@ -194,7 +187,7 @@ emitSaveThreadState bid = do
   emit closeNursery
   -- and save the current cost centre stack in the TSO when profiling:
   when opt_SccProfilingOn $
-	emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
+        emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
 
    -- CurrentNursery->free = Hp+1;
 closeNursery :: CmmAGraph
@@ -205,19 +198,19 @@ loadThreadState tso stack = do
   -- tso <- newTemp gcWord -- TODO FIXME NOW
   -- stack <- newTemp gcWord -- TODO FIXME NOW
   catAGraphs [
-	-- tso = CurrentTSO;
-  	mkAssign (CmmLocal tso) stgCurrentTSO,
-	-- stack = tso->stackobj;
-	mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
-	-- Sp = stack->sp;
-	mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord),
-	-- SpLim = stack->stack + RESERVED_STACK_WORDS;
-	mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
-			            rESERVED_STACK_WORDS),
+        -- tso = CurrentTSO;
+        mkAssign (CmmLocal tso) stgCurrentTSO,
+        -- stack = tso->stackobj;
+        mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
+        -- Sp = stack->sp;
+        mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord),
+        -- SpLim = stack->stack + RESERVED_STACK_WORDS;
+        mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
+                                    rESERVED_STACK_WORDS),
         openNursery,
         -- and load the current cost centre stack from the TSO when profiling:
         if opt_SccProfilingOn then
-	  mkStore curCCSAddr
+          mkStore curCCSAddr
                   (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
         else mkNop]
 emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
@@ -226,22 +219,22 @@ emitLoadThreadState tso stack = emit $ loadThreadState tso stack
 openNursery :: CmmAGraph
 openNursery = catAGraphs [
         -- Hp = CurrentNursery->free - 1;
-	mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
-
-        -- HpLim = CurrentNursery->start + 
-	--		CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-	mkAssign hpLim
-	    (cmmOffsetExpr
-		(CmmLoad nursery_bdescr_start bWord)
-		(cmmOffset
-		  (CmmMachOp mo_wordMul [
-		    CmmMachOp (MO_SS_Conv W32 wordWidth)
-		      [CmmLoad nursery_bdescr_blocks b32],
-		    CmmLit (mkIntCLit bLOCK_SIZE)
-		   ])
-		  (-1)
-		)
-	    )
+        mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
+
+        -- HpLim = CurrentNursery->start +
+        --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+        mkAssign hpLim
+            (cmmOffsetExpr
+                (CmmLoad nursery_bdescr_start bWord)
+                (cmmOffset
+                  (CmmMachOp mo_wordMul [
+                    CmmMachOp (MO_SS_Conv W32 wordWidth)
+                      [CmmLoad nursery_bdescr_blocks b32],
+                    CmmLit (mkIntCLit bLOCK_SIZE)
+                   ])
+                  (-1)
+                )
+            )
    ]
 emitOpenNursery :: FCode ()
 emitOpenNursery = emit openNursery
@@ -262,18 +255,18 @@ closureField :: ByteOff -> ByteOff
 closureField off = off + fixedHdrSize * wORD_SIZE
 
 stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
-stgSp		  = CmmReg sp
-stgHp		  = CmmReg hp
-stgCurrentTSO	  = CmmReg currentTSO
+stgSp             = CmmReg sp
+stgHp             = CmmReg hp
+stgCurrentTSO     = CmmReg currentTSO
 stgCurrentNursery = CmmReg currentNursery
 
 sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
-sp		  = CmmGlobal Sp
-spLim		  = CmmGlobal SpLim
-hp		  = CmmGlobal Hp
-hpLim		  = CmmGlobal HpLim
-currentTSO	  = CmmGlobal CurrentTSO
-currentNursery 	  = CmmGlobal CurrentNursery
+sp                = CmmGlobal Sp
+spLim             = CmmGlobal SpLim
+hp                = CmmGlobal Hp
+hpLim             = CmmGlobal HpLim
+currentTSO        = CmmGlobal CurrentTSO
+currentNursery    = CmmGlobal CurrentNursery
 
 -- -----------------------------------------------------------------------------
 -- For certain types passed to foreign calls, we adjust the actual
@@ -286,18 +279,18 @@ getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
 -- It's (b) that makes this differ from getNonVoidArgAmodes
 
 getFCallArgs args
-  = do	{ mb_cmms <- mapM get args
-	; return (catMaybes mb_cmms) }
+  = do  { mb_cmms <- mapM get args
+        ; return (catMaybes mb_cmms) }
   where
-    get arg | isVoidRep arg_rep 
-	    = return Nothing
-	    | otherwise
-	    = do { cmm <- getArgAmode (NonVoid arg)
-		 ; return (Just (add_shim arg_ty cmm, hint)) }
-	    where
-	      arg_ty  = stgArgType arg
-	      arg_rep = typePrimRep arg_ty
-	      hint    = typeForeignHint arg_ty
+    get arg | isVoidRep arg_rep
+            = return Nothing
+            | otherwise
+            = do { cmm <- getArgAmode (NonVoid arg)
+                 ; return (Just (add_shim arg_ty cmm, hint)) }
+            where
+              arg_ty  = stgArgType arg
+              arg_rep = typePrimRep arg_ty
+              hint    = typeForeignHint arg_ty
 
 add_shim :: Type -> CmmExpr -> CmmExpr
 add_shim arg_ty expr
@@ -308,6 +301,6 @@ add_shim arg_ty expr
   = cmmOffsetB expr arrWordsHdrSize
 
   | otherwise = expr
-  where	
+  where
     tycon = tyConAppTyCon (repType arg_ty)
-	-- should be a tycon app, since this is a foreign call
+        -- should be a tycon app, since this is a foreign call
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index e11acbf563..d3a2ca5cbb 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -1282,6 +1282,13 @@ altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 \begin{code}
 data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int }
 
+
+instance Outputable CoreStats where 
+ ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) = 
+    text "size of" <+> vcat [ text "terms     =" <+> int i1
+                            , text "types     =" <+> int i2
+                            , text "coercions =" <+> int i3 ]
+
 plusCS :: CoreStats -> CoreStats -> CoreStats
 plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 })
        (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 })
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index d0713bcf99..cb23075134 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -153,14 +153,8 @@ deSugar hsc_env
         -- You might think it doesn't matter, but the simplifier brings all top-level
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
-        -- Lint result if necessary, and print
-{-
-        ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
-               (vcat [ pprCoreBindings final_pgm
-                     , pprRules rules_for_imps ])
--}
-
 #ifdef DEBUG
+          -- Debug only as pre-simple-optimisation program may be really big
         ; endPass dflags CoreDesugar final_pgm rules_for_imps 
 #endif
         ; (ds_binds, ds_rules_for_imps, ds_vects) 
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 22a4a7bdde..6f9bbc2ef8 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -125,8 +125,8 @@ dsFImport :: Id
           -> Coercion
           -> ForeignImport
           -> DsM ([Binding], SDoc, SDoc)
-dsFImport id co (CImport cconv safety _ spec) = do
-    (ids, h, c) <- dsCImport id co spec cconv safety
+dsFImport id co (CImport cconv safety header spec) = do
+    (ids, h, c) <- dsCImport id co spec cconv safety header
     return (ids, h, c)
 
 dsCImport :: Id
@@ -134,8 +134,9 @@ dsCImport :: Id
           -> CImportSpec
           -> CCallConv
           -> Safety
+          -> FastString -- header
           -> DsM ([Binding], SDoc, SDoc)
-dsCImport id co (CLabel cid) cconv _ = do
+dsCImport id co (CLabel cid) cconv _ _ = do
    let ty = pFst $ coercionKind co
        fod = case tyConAppTyCon_maybe ty of
              Just tycon
@@ -151,11 +152,11 @@ dsCImport id co (CLabel cid) cconv _ = do
     in
     return ([(id, rhs')], empty, empty)
 
-dsCImport id co (CFunction target) cconv@PrimCallConv safety
+dsCImport id co (CFunction target) cconv@PrimCallConv safety _
   = dsPrimCall id co (CCall (CCallSpec target cconv safety))
-dsCImport id co (CFunction target) cconv safety
-  = dsFCall id co (CCall (CCallSpec target cconv safety))
-dsCImport id co CWrapper cconv _
+dsCImport id co (CFunction target) cconv safety header
+  = dsFCall id co (CCall (CCallSpec target cconv safety)) header
+dsCImport id co CWrapper cconv _ _
   = dsFExportDynamic id co cconv
 
 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
@@ -181,8 +182,9 @@ fun_type_arg_stdcall_info _other_conv _
 %************************************************************************
 
 \begin{code}
-dsFCall :: Id -> Coercion -> ForeignCall -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
-dsFCall fn_id co fcall = do
+dsFCall :: Id -> Coercion -> ForeignCall -> FastString
+        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsFCall fn_id co fcall headerFilename = do
     let
         ty                   = pFst $ coercionKind co
         (tvs, fun_ty)        = tcSplitForAllTys ty
@@ -200,10 +202,48 @@ dsFCall fn_id co fcall = do
 
     ccall_uniq <- newUnique
     work_uniq  <- newUnique
+
+    (fcall', cDoc) <-
+              case fcall of
+              CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) ->
+               do fcall_uniq <- newUnique
+                  let wrapperName = mkFastString "ghc_wrapper_" `appendFS`
+                                    mkFastString (showSDoc (ppr fcall_uniq)) `appendFS`
+                                    mkFastString "_" `appendFS`
+                                    cName
+                      fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId) CApiConv safety)
+                      c = include
+                       $$ fun_proto <+> braces (cRet <> semi)
+                      include
+                       | nullFS headerFilename = empty
+                       | otherwise = text "#include <" <> ftext headerFilename <> text ">"
+                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
+                      cRet
+                       | isVoidRes =                   cCall
+                       | otherwise = text "return" <+> cCall
+                      cCall = ppr cName <> parens argVals
+                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
+                                   Just (_ioTyCon, res_ty) -> res_ty
+                                   Nothing                 -> io_res_ty
+                      isVoidRes = raw_res_ty `eqType` unitTy
+                      cResType | isVoidRes = text "void"
+                               | otherwise = showStgType raw_res_ty
+                      pprCconv = ccallConvAttribute CApiConv
+                      argTypes
+                       | null arg_tys = text "void"
+                       | otherwise = hsep $ punctuate comma
+                                         [ showStgType t <+> char 'a' <> int n
+                                         | (t, n) <- zip arg_tys [1..] ]
+                      argVals = hsep $ punctuate comma
+                                    [ char 'a' <> int n
+                                    | (_, n) <- zip arg_tys [1..] ]
+                  return (fcall', c)
+              _ ->
+                  return (fcall, empty)
     let
         -- Build the worker
         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
-        the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
+        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
         work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
 
@@ -214,7 +254,7 @@ dsFCall fn_id co fcall = do
         wrap_rhs'    = Cast wrap_rhs co
         fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfolding (Just (length args)) wrap_rhs'
 
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, empty)
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
 \end{code}
 
 
@@ -299,13 +339,11 @@ dsFExport fn_id co ext_name cconv isDyn = do
        -- Look at the result type of the exported function, orig_res_ty
        -- If it's IO t, return         (t, True)
        -- If it's plain t, return      (t, False)
-    (res_ty,             -- t
-     is_IO_res_ty) <-    -- Bool
-        case tcSplitIOType_maybe orig_res_ty of
-           Just (_ioTyCon, res_ty) -> return (res_ty, True)
-                   -- The function already returns IO t
-           Nothing                    -> return (orig_res_ty, False)
-                   -- The function returns t
+       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
+                                -- The function already returns IO t
+                                Just (_ioTyCon, res_ty) -> (res_ty, True)
+                                -- The function returns t
+                                Nothing                 -> (orig_res_ty, False)
 
     dflags <- getDOpts
     return $
@@ -511,10 +549,7 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
                int64TyConKey, word64TyConKey]
 
   -- Now we can cook up the prototype for the exported function.
-  pprCconv = case cc of
-                CCallConv   -> empty
-                StdCallConv -> text (ccallConvAttribute cc)
-                _           -> panic ("mkFExportCBits/pprCconv " ++ showPpr cc)
+  pprCconv = ccallConvAttribute cc
 
   header_bits = ptext (sLit "extern") <+> fun_proto <> semi
 
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index b2ad4c501f..b039d39960 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -239,6 +239,7 @@ genCall env target res args ret = do
                             ArchX86_64 -> CC_X86_Stdcc
                             _          -> CC_Ccc
             CCallConv    -> CC_Ccc
+            CApiConv     -> CC_Ccc
             PrimCallConv -> CC_Ccc
             CmmCallConv  -> panic "CmmCallConv not supported here!"
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index fce75b0bff..9d6d15c0df 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -378,6 +378,7 @@ data ExtensionFlag
    | Opt_ForeignFunctionInterface
    | Opt_UnliftedFFITypes
    | Opt_InterruptibleFFI
+   | Opt_CApiFFI
    | Opt_GHCForeignImportPrim
    | Opt_ParallelArrays           -- Syntactic support for parallel arrays
    | Opt_Arrows                   -- Arrow-notation syntax
@@ -1898,6 +1899,7 @@ xFlags = [
   ( "ForeignFunctionInterface",         Opt_ForeignFunctionInterface, nop ),
   ( "UnliftedFFITypes",                 Opt_UnliftedFFITypes, nop ),
   ( "InterruptibleFFI",                 Opt_InterruptibleFFI, nop ),
+  ( "CApiFFI",                          Opt_CApiFFI, nop ),
   ( "GHCForeignImportPrim",             Opt_GHCForeignImportPrim, nop ),
   ( "LiberalTypeSynonyms",              Opt_LiberalTypeSynonyms, nop ),
   ( "Rank2Types",                       Opt_Rank2Types, nop ),
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 4d106bd67e..b4cfbf403f 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -404,14 +404,14 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
 -- | Convert a typechecked module to Core
 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
 hscDesugar hsc_env mod_summary tc_result =
-    runHsc hsc_env $ hscDesugar' mod_summary tc_result
+    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
 
-hscDesugar' :: ModSummary -> TcGblEnv -> Hsc ModGuts
-hscDesugar' mod_summary tc_result = do
+hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
+hscDesugar' mod_location tc_result = do
     hsc_env <- getHscEnv
     r <- ioMsgMaybe $
       {-# SCC "deSugar" #-}
-      deSugar hsc_env (ms_location mod_summary) tc_result
+      deSugar hsc_env mod_location tc_result
 
     -- always check -Werror after desugaring, this is the last opportunity for
     -- warnings to arise before the backend.
@@ -616,7 +616,7 @@ genericHscBackend compiler tc_result mod_summary mb_old_hash
     | HsBootFile <- ms_hsc_src mod_summary =
         hscGenBootOutput compiler tc_result mod_summary mb_old_hash
     | otherwise = do
-        guts <- hscDesugar' mod_summary tc_result
+        guts <- hscDesugar' (ms_location mod_summary) tc_result
         hscGenOutput compiler guts mod_summary mb_old_hash
 
 compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a
@@ -1423,8 +1423,7 @@ hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do
     let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
                                       ml_hi_file   = undefined,
                                       ml_obj_file  = undefined}
-    ds_result <- ioMsgMaybe $ deSugar hsc_env iNTERACTIVELoc tc_gblenv
-    handleWarnings
+    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
 
     {- Simplify -}
     simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs
index 1db5ef63e0..07eb214f74 100644
--- a/compiler/main/StaticFlagParser.hs
+++ b/compiler/main/StaticFlagParser.hs
@@ -132,6 +132,7 @@ static_flags = [
   , Flag "dsuppress-module-prefixes"   (PassFlag addOpt)
   , Flag "dsuppress-type-applications" (PassFlag addOpt)
   , Flag "dsuppress-idinfo"            (PassFlag addOpt)
+  , Flag "dsuppress-var-kinds"         (PassFlag addOpt)
   , Flag "dsuppress-type-signatures"   (PassFlag addOpt)
   , Flag "dopt-fuel"                   (AnySuffix addOpt)
   , Flag "dtrace-level"                (AnySuffix addOpt)
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index e89d9b32a4..c2f8674aa9 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -41,6 +41,7 @@ module StaticFlags (
 	opt_SuppressTypeApplications,
 	opt_SuppressIdInfo,
 	opt_SuppressTypeSignatures,
+        opt_SuppressVarKinds,
 
 	-- profiling opts
 	opt_SccProfilingOn,
@@ -223,6 +224,11 @@ opt_SuppressCoercions
 	=  lookUp  (fsLit "-dsuppress-all")
 	|| lookUp  (fsLit "-dsuppress-coercions")
 
+opt_SuppressVarKinds :: Bool
+opt_SuppressVarKinds
+	=  lookUp  (fsLit "-dsuppress-all")
+	|| lookUp  (fsLit "-dsuppress-var-kinds")
+
 -- | Suppress module id prefixes on variables.
 opt_SuppressModulePrefixes :: Bool
 opt_SuppressModulePrefixes
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index ea01070c94..f235465758 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -457,6 +457,7 @@ data Token
   | ITunsafe
   | ITstdcallconv
   | ITccallconv
+  | ITcapiconv
   | ITprimcallconv
   | ITmdo
   | ITfamily
@@ -642,6 +643,7 @@ reservedWordsFM = listToUFM $
          ( "unsafe",         ITunsafe,        bit ffiBit),
          ( "stdcall",        ITstdcallconv,   bit ffiBit),
          ( "ccall",          ITccallconv,     bit ffiBit),
+         ( "capi",           ITcapiconv,      bit cApiFfiBit),
          ( "prim",           ITprimcallconv,  bit ffiBit),
 
          ( "rec",            ITrec,           bit recBit),
@@ -1754,6 +1756,8 @@ ffiBit :: Int
 ffiBit= 0
 interruptibleFfiBit :: Int
 interruptibleFfiBit = 1
+cApiFfiBit :: Int
+cApiFfiBit = 2
 parrBit :: Int
 parrBit = 3
 arrowsBit :: Int
@@ -1879,6 +1883,7 @@ mkPState flags buf loc =
     where
       bitmap =     ffiBit                      `setBitIf` xopt Opt_ForeignFunctionInterface flags
                .|. interruptibleFfiBit         `setBitIf` xopt Opt_InterruptibleFFI         flags
+               .|. cApiFfiBit                  `setBitIf` xopt Opt_CApiFFI                  flags
                .|. parrBit                     `setBitIf` xopt Opt_ParallelArrays           flags
                .|. arrowsBit                   `setBitIf` xopt Opt_Arrows                   flags
                .|. thBit                       `setBitIf` xopt Opt_TemplateHaskell          flags
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index de15f1cf2f..8a57504e68 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -244,6 +244,7 @@ incorrect.
  'family'       { L _ ITfamily }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
+ 'capi'         { L _ ITcapiconv }
  'prim'         { L _ ITprimcallconv }
  'proc'         { L _ ITproc }          -- for arrow notation extension
  'rec'          { L _ ITrec }           -- for arrow notation extension
@@ -922,6 +923,7 @@ fdecl : 'import' callconv safety fspec
 callconv :: { CCallConv }
           : 'stdcall'                   { StdCallConv }
           | 'ccall'                     { CCallConv   }
+          | 'capi'                      { CApiConv    }
           | 'prim'                      { PrimCallConv}
 
 safety :: { Safety }
@@ -1394,6 +1396,7 @@ scc_annot :: { Located FastString }
         : '_scc_' STRING                        {% (addWarning Opt_WarnWarningsDeprecations (getLoc $1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ ->
                                    ( do scc <- getSCC $2; return $ LL scc ) }
         | '{-# SCC' STRING '#-}'                {% do scc <- getSCC $2; return $ LL scc }
+        | '{-# SCC' VARID  '#-}'                { LL (getVARID $2) }
 
 hpc_annot :: { Located (FastString,(Int,Int),(Int,Int)) }
         : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
@@ -1944,6 +1947,7 @@ special_id
         | 'dynamic'             { L1 (fsLit "dynamic") }
         | 'stdcall'             { L1 (fsLit "stdcall") }
         | 'ccall'               { L1 (fsLit "ccall") }
+        | 'capi'                { L1 (fsLit "capi") }
         | 'prim'                { L1 (fsLit "prim") }
         | 'group'               { L1 (fsLit "group") }
 
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index 5e0f9ec5c0..f959fb08d4 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -151,13 +151,15 @@ platforms.
 See: http://www.programmersheaven.com/2/Calling-conventions
 
 \begin{code}
-data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
+data CCallConv = CCallConv | CApiConv | StdCallConv
+               | CmmCallConv | PrimCallConv
   deriving (Eq, Data, Typeable)
   {-! derive: Binary !-}
 
 instance Outputable CCallConv where
   ppr StdCallConv = ptext (sLit "stdcall")
   ppr CCallConv   = ptext (sLit "ccall")
+  ppr CApiConv    = ptext (sLit "capi")
   ppr CmmCallConv = ptext (sLit "C--")
   ppr PrimCallConv = ptext (sLit "prim")
 
@@ -167,6 +169,7 @@ defaultCCallConv = CCallConv
 ccallConvToInt :: CCallConv -> Int
 ccallConvToInt StdCallConv = 0
 ccallConvToInt CCallConv   = 1
+ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
 ccallConvToInt (CmmCallConv {})  = panic "ccallConvToInt CmmCallConv"
 ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
 \end{code}
@@ -175,9 +178,10 @@ Generate the gcc attribute corresponding to the given
 calling convention (used by PprAbsC):
 
 \begin{code}
-ccallConvAttribute :: CCallConv -> String
-ccallConvAttribute StdCallConv = "__attribute__((__stdcall__))"
-ccallConvAttribute CCallConv   = ""
+ccallConvAttribute :: CCallConv -> SDoc
+ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
+ccallConvAttribute CCallConv         = empty
+ccallConvAttribute CApiConv          = empty
 ccallConvAttribute (CmmCallConv {})  = panic "ccallConvAttribute CmmCallConv"
 ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
 \end{code}
@@ -294,11 +298,14 @@ instance Binary CCallConv where
             putByte bh 2
     put_ bh CmmCallConv = do
             putByte bh 3
+    put_ bh CApiConv = do
+            putByte bh 4
     get bh = do
             h <- getByte bh
             case h of
               0 -> do return CCallConv
               1 -> do return StdCallConv
               2 -> do return PrimCallConv
-              _ -> do return CmmCallConv
+              3 -> do return CmmCallConv
+              _ -> do return CApiConv
 \end{code}
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 09a5403508..726c9a57b9 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -32,7 +32,7 @@ import Name ( Name )
 import Var
 import VarEnv
 import Outputable
-import Control.Monad    ( when, unless, zipWithM, zipWithM_, foldM )
+import Control.Monad    ( when, unless, zipWithM, foldM )
 import MonadUtils
 import Control.Applicative ( (<|>) )
 
@@ -166,25 +166,29 @@ are again good.
 canonicalize :: Ct -> TcS StopOrContinue
 canonicalize ct@(CNonCanonical { cc_id = ev, cc_flavor = fl, cc_depth  = d })
   = do { traceTcS "canonicalize (non-canonical)" (ppr ct)
-       ; canEvVar ev (classifyPredType (evVarPred ev)) d fl }
+       ; {-# SCC "canEvVar" #-}
+         canEvVar ev (classifyPredType (evVarPred ev)) d fl }
 
 canonicalize (CDictCan { cc_id = ev, cc_depth = d
                        , cc_flavor = fl
                        , cc_class  = cls
                        , cc_tyargs = xis })
-  = canClass d fl ev cls xis -- Do not add any superclasses
+  = {-# SCC "canClass" #-}
+    canClass d fl ev cls xis -- Do not add any superclasses
 canonicalize (CTyEqCan { cc_id = ev, cc_depth = d
                        , cc_flavor = fl
                        , cc_tyvar  = tv
                        , cc_rhs    = xi })
-  = canEqLeafTyVarLeftRec d fl ev tv xi
+  = {-# SCC "canEqLeafTyVarLeftRec" #-}
+    canEqLeafTyVarLeftRec d fl ev tv xi
 
 canonicalize (CFunEqCan { cc_id = ev, cc_depth = d
                         , cc_flavor = fl
                         , cc_fun    = fn
                         , cc_tyargs = xis1
                         , cc_rhs    = xi2 })
-  = canEqLeafFunEqLeftRec d fl ev (fn,xis1) xi2
+  = {-# SCC "canEqLeafFunEqLeftRec" #-}
+    canEqLeafFunEqLeftRec d fl ev (fn,xis1) xi2
 
 canonicalize (CIPCan { cc_id = ev, cc_depth = d
                      , cc_flavor = fl
@@ -225,16 +229,19 @@ canTuple :: SubGoalDepth -- Depth
 canTuple d fl ev tys
   = do { traceTcS "can_pred" (text "TuplePred!") 
        ; evs <- zipWithM can_pred_tup_one tys [0..]
-       ; when (isWanted fl) $ setEvBind ev (EvTupleMk evs)
-       ; return Stop }
+       ; if (isWanted fl) then 
+             do {_unused_fl <- setEvBind ev (EvTupleMk evs) fl
+                ; return Stop }
+         else return Stop }
   where 
      can_pred_tup_one ty n
           = do { evc <- newEvVar fl ty
-               ; let ev' = evc_the_evvar evc 
-               ; when (isGivenOrSolved fl) $ 
-                      setEvBind ev' (EvTupleSel ev n)
-               ; when (isNewEvVar evc)     $ 
-                      addToWork (canEvVar ev' (classifyPredType (evVarPred ev')) d fl)
+               ; let ev' = evc_the_evvar evc
+               ; fl' <- if isGivenOrSolved fl then 
+                            setEvBind ev' (EvTupleSel ev n) fl
+                        else return fl
+               ; when (isNewEvVar evc) $
+                      addToWork (canEvVar ev' (classifyPredType (evVarPred ev')) d fl')
                ; return ev' }
 
 -- Implicit Parameter Canonicalization
@@ -247,21 +254,21 @@ canIP d fl v nm ty
   =    -- Note [Canonical implicit parameter constraints] explains why it's 
        -- possible in principle to not flatten, but since flattening applies 
        -- the inert substitution we choose to flatten anyway.
-    do { (xi,co) <- flatten d fl (mkIPPred nm ty)
-       ; if isReflCo co then
+    do { (xi,co,no_flattening) <- flatten d fl (mkIPPred nm ty)
+       ; if no_flattening then
              continueWith $ CIPCan { cc_id = v, cc_flavor = fl
                                    , cc_ip_nm = nm, cc_ip_ty = ty
                                    , cc_depth = d }
          else do { evc <- newEvVar fl xi
                  ; let v_new          = evc_the_evvar evc
                        IPPred _ ip_xi = classifyPredType xi
-                 ; case fl of 
-                     Wanted {}  -> setEvBind v (EvCast v_new co)
-                     Given {}   -> setEvBind v_new (EvCast v (mkSymCo co))
-                     Derived {} -> return ()
+                 ; fl_new <- case fl of 
+                               Wanted {}  -> setEvBind v (EvCast v_new co) fl 
+                               Given {}   -> setEvBind v_new (EvCast v (mkSymCo co)) fl
+                               Derived {} -> return fl
                  ; if isNewEvVar evc then
                        continueWith $ CIPCan { cc_id     = v_new
-                                             , cc_flavor = fl, cc_ip_nm = nm
+                                             , cc_flavor = fl_new, cc_ip_nm = nm
                                              , cc_ip_ty  = ip_xi
                                              , cc_depth  = d }
                    else return Stop } }
@@ -289,25 +296,25 @@ canClass :: SubGoalDepth -- Depth
 -- Note: Does NOT add superclasses, but the /caller/ is responsible for adding them!
 canClass d fl v cls tys
   = do { -- sctx <- getTcSContext
-       ; (xis, cos) <- flattenMany d fl tys
+       ; (xis, cos, no_flattening) <- flattenMany d fl tys
        ; let co = mkTyConAppCo (classTyCon cls) cos 
              xi = mkClassPred cls xis
 
                   -- No flattening, continue with canonical
-       ; if isReflCo co then 
+       ; if no_flattening then 
              continueWith $ CDictCan { cc_id = v, cc_flavor = fl
                                      , cc_tyargs = xis, cc_class = cls
                                      , cc_depth = d }
                    -- Flattening happened
          else do { evc <- newEvVar fl xi
                  ; let v_new = evc_the_evvar evc
-                 ; case fl of
-                     Wanted  {} -> setEvBind v (EvCast v_new co)
-                     Given   {} -> setEvBind v_new (EvCast v (mkSymCo co))
-                     Derived {} -> return ()
+                 ; fl_new <- case fl of
+                     Wanted  {} -> setEvBind v (EvCast v_new co) fl
+                     Given   {} -> setEvBind v_new (EvCast v (mkSymCo co)) fl
+                     Derived {} -> return fl
                     -- Continue only if flat constraint is new
                  ; if isNewEvVar evc then
-                        continueWith $ CDictCan { cc_id = v_new, cc_flavor = fl
+                        continueWith $ CDictCan { cc_id = v_new, cc_flavor = fl_new
                                                 , cc_tyargs = xis, cc_class = cls
                                                 , cc_depth  = d }
                    else return Stop } }
@@ -392,7 +399,8 @@ newSCWorkFromFlavored d ev flavor cls xis
                       ; sc_vars <- mapM (newEvVar flavor) sc_theta
                       ; sc_cts <- zipWithM (\scv ev_trm -> 
                                                 do { let sc_evvar = evc_the_evvar scv
-                                                   ; setEvBind sc_evvar ev_trm
+                                                   ; _unused_fl <- setEvBind sc_evvar ev_trm flavor
+                                                      -- unused because it's the same
                                                    ; return $ 
                                                      CNonCanonical { cc_id = sc_evvar
                                                                    , cc_flavor = flavor
@@ -402,7 +410,7 @@ newSCWorkFromFlavored d ev flavor cls xis
                       ; traceTcS "newSCWorkFromFlavored" $
                                  text "Emitting superclass work:" <+> ppr sc_cts
                       ; updWorkListTcS $ appendWorkListCt sc_cts }
-      GivenSolved -> return ()
+      GivenSolved {} -> return ()
       -- Seems very dangerous to add the superclasses for dictionaries that may be 
       -- partially solved because we may end up with evidence loops.
 
@@ -447,8 +455,7 @@ canIrred :: SubGoalDepth -- Depth
 -- Precondition: ty not a tuple and no other evidence form
 canIrred d fl v ty 
   = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) 
-       ; (xi,co) <- flatten d fl ty -- co :: xi ~ ty
-       ; let no_flattening = isReflCo co
+       ; (xi,co,no_flattening) <- flatten d fl ty -- co :: xi ~ ty
        ; if no_flattening then
             continueWith $ CIrredEvCan { cc_id = v, cc_flavor = fl
                                        , cc_ty = xi, cc_depth  = d }
@@ -458,13 +465,13 @@ canIrred d fl v ty
           -- canonicalise the resulting evidence variable
         evc <- newEvVar fl xi
       ; let v' = evc_the_evvar evc
-      ; case fl of 
-          Wanted  {} -> setEvBind v (EvCast v' co)
-          Given   {} -> setEvBind v' (EvCast v (mkSymCo co)) 
-          Derived {} -> return ()
+      ; fl' <- case fl of 
+          Wanted  {} -> setEvBind v (EvCast v' co) fl
+          Given   {} -> setEvBind v' (EvCast v (mkSymCo co)) fl
+          Derived {} -> return fl
       
       ; if isNewEvVar evc then 
-            canEvVar v' (classifyPredType (evVarPred v')) d fl
+            canEvVar v' (classifyPredType (evVarPred v')) d fl'
         else
             return Stop }
       }
@@ -516,64 +523,70 @@ transitive expansion contains any type function applications.  If so,
 it expands the synonym and proceeds; if not, it simply returns the
 unexpanded synonym.
 
-TODO: caching the information about whether transitive synonym
-expansions contain any type function applications would speed things
-up a bit; right now we waste a lot of energy traversing the same types
-multiple times.
-
 \begin{code}
 
 -- Flatten a bunch of types all at once.
 flattenMany :: SubGoalDepth -- Depth
-            -> CtFlavor -> [Type] -> TcS ([Xi], [LCoercion])
+            -> CtFlavor -> [Type] -> TcS ([Xi], [LCoercion],Bool)
 -- Coercions :: Xi ~ Type 
+-- Returns True iff (no flattening happened)
 flattenMany d ctxt tys 
-  = do { (xis, cos) <- mapAndUnzipM (flatten d ctxt) tys
-       ; return (xis, cos) }
+  = -- pprTrace "flattenMany" empty $
+    go tys 
+  where go []       = return ([],[],True)
+        go (ty:tys) = do { (xi,co,flag_ty)    <- flatten d ctxt ty
+                         ; (xis,cos,flag_tys) <- go tys
+                         ; return (xi:xis,co:cos,flag_ty && flag_tys) }
 
 -- Flatten a type to get rid of type function applications, returning
 -- the new type-function-free type, and a collection of new equality
 -- constraints.  See Note [Flattening] for more detail.
 flatten :: SubGoalDepth -- Depth
-        -> CtFlavor -> TcType -> TcS (Xi, LCoercion)
+        -> CtFlavor -> TcType -> TcS (Xi, LCoercion,Bool)
 -- Postcondition: Coercion :: Xi ~ TcType
+-- Boolean flag to return: True iff (no flattening happened)
+-- Notice the returned flag is NOT equal to isReflCo of the returned coercion
+-- because of spontaneously solved equalities, whose evidence IS refl, but the 
+-- types are substituted!
 flatten d ctxt ty 
   | Just ty' <- tcView ty
-  = do { (xi, co) <- flatten d ctxt ty'
+  = do { (xi, co, no_flattening) <- flatten d ctxt ty'
 	-- Preserve type synonyms if possible
-       ; if isReflCo co 
-         then return (ty, mkReflCo ty) -- Importantly, not xi!
-         else return (xi, co) 
+       ; if no_flattening
+         then return (ty, mkReflCo ty,no_flattening) -- Importantly, not xi!
+         else return (xi,co,no_flattening) 
        }
 
 flatten _d ctxt v@(TyVarTy _)
   = do { ieqs <- getInertEqs
-       ; let co = liftInertEqsTy ieqs ctxt v                 -- co :: v ~ xi
-       ; return (pSnd (liftedCoercionKind co), mkSymCo co) } -- return xi ~ v
+       ; let co = liftInertEqsTy ieqs ctxt v             -- co :: v ~ xi
+             new_ty = pSnd (liftedCoercionKind co)
+             no_substitution = new_ty `eqType` v         -- Very cheap
+       ; return (new_ty, mkSymCo co,no_substitution) }   -- return xi ~ v
 
 flatten d ctxt (AppTy ty1 ty2)
-  = do { (xi1,co1) <- flatten d ctxt ty1
-       ; (xi2,co2) <- flatten d ctxt ty2
-       ; return (mkAppTy xi1 xi2, mkAppCo co1 co2) }
+  = do { (xi1,co1,no_flat1) <- flatten d ctxt ty1
+       ; (xi2,co2,no_flat2) <- flatten d ctxt ty2
+       ; return (mkAppTy xi1 xi2, mkAppCo co1 co2,no_flat1 && no_flat2) }
 
 flatten d ctxt (FunTy ty1 ty2)
-  = do { (xi1,co1) <- flatten d ctxt ty1
-       ; (xi2,co2) <- flatten d ctxt ty2
-       ; return (mkFunTy xi1 xi2, mkFunCo co1 co2) }
+  = do { (xi1,co1,no_flat1) <- flatten d ctxt ty1
+       ; (xi2,co2,no_flat2) <- flatten d ctxt ty2
+       ; return (mkFunTy xi1 xi2, mkFunCo co1 co2, no_flat1 && no_flat2) }
 
 flatten d fl (TyConApp tc tys)
   -- For a normal type constructor or data family application, we just
   -- recursively flatten the arguments.
   | not (isSynFamilyTyCon tc)
-    = do { (xis,cos) <- flattenMany d fl tys
-         ; return (mkTyConApp tc xis, mkTyConAppCo tc cos) }
+    = do { (xis,cos,no_flattening) <- flattenMany d fl tys
+         ; return (mkTyConApp tc xis, mkTyConAppCo tc cos,no_flattening) }
 
   -- Otherwise, it's a type function application, and we have to
   -- flatten it away as well, and generate a new given equality constraint
   -- between the application and a newly generated flattening skolem variable.
   | otherwise
   = ASSERT( tyConArity tc <= length tys )	-- Type functions are saturated
-      do { (xis, cos) <- flattenMany d fl tys
+      do { (xis, cos, _no_flattening) <- flattenMany d fl tys
          ; let (xi_args, xi_rest)  = splitAt (tyConArity tc) xis
 	       	 -- The type function might be *over* saturated
 		 -- in which case the remaining arguments should
@@ -588,16 +601,16 @@ flatten d fl (TyConApp tc tys)
                     Nothing
                         | isGivenOrSolved fl ->
                             do { rhs_xi_var <- newFlattenSkolemTy fam_ty
-                               ; eqv <- newGivenEqVar fl fam_ty rhs_xi_var (mkReflCo fam_ty)
+                               ; (fl',eqv) 
+                                   <- newGivenEqVar fl fam_ty rhs_xi_var (mkReflCo fam_ty)
                                ; let ct  = CFunEqCan { cc_id     = eqv
-                                                     , cc_flavor = fl -- Given
+                                                     , cc_flavor = fl' -- Given
                                                      , cc_fun    = tc 
                                                      , cc_tyargs = xi_args 
                                                      , cc_rhs    = rhs_xi_var 
                                                      , cc_depth  = d }
                                            -- Update the flat cache: just an optimisation!
-                               ; updateFlatCache eqv fl tc xi_args rhs_xi_var WhileFlattening
-
+                               ; updateFlatCache eqv fl' tc xi_args rhs_xi_var WhileFlattening
                                ; return (mkEqVarLCo eqv, rhs_xi_var, [ct]) }
                         | otherwise ->
                     -- Derived or Wanted: make a new /unification/ flatten variable
@@ -623,7 +636,8 @@ flatten d fl (TyConApp tc tys)
          ; return ( mkAppTys rhs_xi xi_rest    -- NB mkAppTys: rhs_xi might not be a type variable
 	   	    	     	    	       --    cf Trac #5655
                   , foldl AppCo (mkSymCo ret_co `mkTransCo` mkTyConAppCo tc cos_args)
-                                cos_rest) }
+                                cos_rest
+                  , False ) } -- no_flattening is False since we ARE flattening here!
 
 
 flatten d ctxt ty@(ForAllTy {})
@@ -631,8 +645,8 @@ flatten d ctxt ty@(ForAllTy {})
 -- applications inside the forall involve the bound type variables.
   = do { let (tvs, rho) = splitForAllTys ty
        ; when (under_families tvs rho) $ flattenForAllErrorTcS ctxt ty
-       ; (rho', co) <- flatten d ctxt rho
-       ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs) }
+       ; (rho', co, no_flattening) <- flatten d ctxt rho
+       ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, no_flattening) }
 
   where under_families tvs rho 
             = go (mkVarSet tvs) rho 
@@ -658,15 +672,19 @@ getCachedFlatEq tc xi_args fl feq_origin
        ; flat_cache <- getTcSEvVarFlatCache
        ; inerts <- getTcSInerts
        ; case lookupFunEq pty fl (inert_funeqs inerts) of
-           Nothing -> lookup_in_flat_cache pty flat_cache
-           res     -> return res }
+           Nothing 
+               -> lookup_in_flat_cache pty flat_cache
+           res -> return res }
   where lookup_in_flat_cache pty flat_cache 
           = case lookupTM pty flat_cache of
               Just (co',(xi',fl',when_generated)) -- ev' :: (TyConApp tc xi_args) ~ xi'
                | fl' `canRewrite` fl
                , feq_origin `origin_matches` when_generated
                -> do { traceTcS "getCachedFlatEq" $ text "success!"
-                     ; (xi'',co) <- flatten 0 fl' xi' -- co :: xi'' ~ xi'
+                     ; (xi'',co,_) <- flatten 0 fl' xi' -- co :: xi'' ~ xi'
+                                    -- The only purpose of this flattening is to apply the
+                                    -- inert substitution (since everything in the flat cache
+                                    -- by construction will have a family-free RHS.
                      ; return $ Just (xi'', co' `mkTransCo` (mkSymCo co)) }
               _ -> do { traceTcS "getCachedFlatEq" $ text "failure!" <+> pprEvVarCache flat_cache
                       ; return Nothing }
@@ -684,11 +702,11 @@ addToWork tcs_action = tcs_action >>= stop_or_emit
         stop_or_emit (ContinueWith ct) = updWorkListTcS $ 
                                          extendWorkListCt ct
 
-canEqEvVarsCreated :: SubGoalDepth -> CtFlavor 
-                   -> [EvVarCreated] -> [Type] -> [Type]
+canEqEvVarsCreated :: SubGoalDepth 
+                   -> [CtFlavor] -> [EvVarCreated] -> [Type] -> [Type]
                    -> TcS StopOrContinue
 canEqEvVarsCreated _d _fl [] _ _    = return Stop
-canEqEvVarsCreated d fl (evc:evcs) (ty1:tys1) (ty2:tys2) 
+canEqEvVarsCreated d (fl:fls) (evc:evcs) (ty1:tys1) (ty2:tys2) 
   | isNewEvVar evc 
   = let do_one evc0 sy1 sy2
           | isNewEvVar evc0 
@@ -697,7 +715,7 @@ canEqEvVarsCreated d fl (evc:evcs) (ty1:tys1) (ty2:tys2)
     in do { _unused <- zipWith3M do_one evcs tys1 tys2 
           ; canEq d fl (evc_the_evvar evc) ty1 ty2 }
   | otherwise 
-  = canEqEvVarsCreated d fl evcs tys1 tys2
+  = canEqEvVarsCreated d fls evcs tys1 tys2
 canEqEvVarsCreated _ _ _ _ _ = return Stop
 
 
@@ -710,7 +728,8 @@ canEq :: SubGoalDepth
 canEq _d fl eqv ty1 ty2
   | eqType ty1 ty2	-- Dealing with equality here avoids
     	     	 	-- later spurious occurs checks for a~a
-  = do { when (isWanted fl) (setEqBind eqv (mkReflCo ty1))
+  = do { when (isWanted fl) $ 
+              do { _ <- setEqBind eqv (mkReflCo ty1) fl; return () }
        ; return Stop }
 
 -- Split up an equality between function types into two equalities.
@@ -719,16 +738,19 @@ canEq d fl eqv (FunTy s1 t1) (FunTy s2 t2)
        ; reseqv <- newEqVar fl t1 t2
        ; let argeqv_v = evc_the_evvar argeqv
              reseqv_v = evc_the_evvar reseqv
-       ; case fl of
+       ; (fl1,fl2) <- case fl of
            Wanted {} ->
-               setEqBind eqv (mkFunCo (mkEqVarLCo argeqv_v) (mkEqVarLCo reseqv_v))
+               do { _ <- setEqBind eqv (mkFunCo (mkEqVarLCo argeqv_v) (mkEqVarLCo reseqv_v)) fl
+                  ; return (fl,fl) }
            Given {} ->
-               do { setEqBind argeqv_v (mkNthCo 0 (mkEqVarLCo eqv))
-                  ; setEqBind reseqv_v (mkNthCo 1 (mkEqVarLCo eqv)) }
+               do { fl1 <- setEqBind argeqv_v (mkNthCo 0 (mkEqVarLCo eqv)) fl
+                  ; fl2 <- setEqBind reseqv_v (mkNthCo 1 (mkEqVarLCo eqv)) fl 
+                  ; return (fl1,fl2)
+                  }
            Derived {} ->
-               return ()
+               return (fl,fl)
 
-       ; canEqEvVarsCreated d fl [reseqv,argeqv] [t1,s1] [t2,s2] }
+       ; canEqEvVarsCreated d [fl2,fl1] [reseqv,argeqv] [t1,s1] [t2,s2] }
 
 -- If one side is a variable, orient and flatten,
 -- WITHOUT expanding type synonyms, so that we tend to 
@@ -755,17 +777,18 @@ canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
        ; let kicos = map mkReflCo kis1
 
        ; argeqvs <- zipWithM (newEqVar fl) tys1' tys2'
-       ; case fl of 
+       ; fls <- case fl of 
            Wanted {} -> 
-             setEqBind eqv $ 
-             mkTyConAppCo tc1 (kicos ++ map (mkEqVarLCo . evc_the_evvar) argeqvs)
+             do { _ <- setEqBind eqv
+                         (mkTyConAppCo tc1 (kicos ++ map (mkEqVarLCo . evc_the_evvar) argeqvs)) fl
+                ; return (map (\_ -> fl) argeqvs) }
            Given {} ->
              let do_one argeqv n = setEqBind (evc_the_evvar argeqv) 
-                                             (mkNthCo n (mkEqVarLCo eqv))
-             in zipWithM_ do_one argeqvs [(length kicos)..]
-           Derived {} -> return ()
+                                             (mkNthCo n (mkEqVarLCo eqv)) fl
+             in zipWithM do_one argeqvs [(length kicos)..]
+           Derived {} -> return (map (\_ -> fl) argeqvs)
 
-       ; canEqEvVarsCreated d fl argeqvs tys1' tys2' }
+       ; canEqEvVarsCreated d fls argeqvs tys1' tys2' }
 
 -- See Note [Equality between type applications]
 --     Note [Care with type applications] in TcUnify
@@ -789,9 +812,10 @@ canEq d fl eqv ty1 ty2
                  eqv2 = evc_the_evvar evc2
  
            ; when (isWanted fl) $
-                  setEqBind eqv (mkAppCo (mkEqVarLCo eqv1) (mkEqVarLCo eqv2))
+                  do { _ <- setEqBind eqv (mkAppCo (mkEqVarLCo eqv1) (mkEqVarLCo eqv2)) fl
+                     ; return () }
            
-           ; canEqEvVarsCreated d fl [evc1,evc2] [s1,t1] [s2,t2] }
+           ; canEqEvVarsCreated d [fl,fl] [evc1,evc2] [s1,t1] [s2,t2] }
 
 
 canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {})
@@ -1019,15 +1043,15 @@ canEqLeaf :: SubGoalDepth -- Depth
 canEqLeaf d fl eqv s1 s2 
   | cls1 `re_orient` cls2
   = do { traceTcS "canEqLeaf (reorienting)" $ ppr (evVarPred eqv)
-       ; delCachedEvVar eqv
+       ; delCachedEvVar eqv fl
        ; evc <- newEqVar fl s2 s1
        ; let eqv' = evc_the_evvar evc
-       ; case fl of 
-           Wanted {}  -> setEqBind eqv (mkSymCo (mkEqVarLCo eqv'))
-           Given {}   -> setEqBind eqv' (mkSymCo (mkEqVarLCo eqv))
-           Derived {} -> return ()
+       ; fl' <- case fl of 
+           Wanted {}  -> setEqBind eqv (mkSymCo (mkEqVarLCo eqv')) fl 
+           Given {}   -> setEqBind eqv' (mkSymCo (mkEqVarLCo eqv)) fl 
+           Derived {} -> return fl 
        ; if isNewEvVar evc then 
-             do { canEqLeafOriented d fl eqv' s2 s1 }
+             do { canEqLeafOriented d fl' eqv' s2 s1 }
          else return Stop 
        }
   | otherwise
@@ -1071,15 +1095,22 @@ canEqLeafFunEqLeftRec :: SubGoalDepth
                       -> (TyCon,[TcType]) -> TcType -> TcS StopOrContinue
 canEqLeafFunEqLeftRec d fl eqv (fn,tys1) ty2  -- eqv :: F tys1 ~ ty2
   = do { traceTcS "canEqLeafFunEqLeftRec" $ ppr (evVarPred eqv)
-       ; (xis1,cos1) <- flattenMany d fl tys1 -- Flatten type function arguments
-                                              -- cos1 :: xis1 ~ tys1
+       ; (xis1,cos1,no_flattening) <- 
+           {-# SCC "flattenMany" #-}
+           flattenMany d fl tys1 -- Flatten type function arguments
+                                 -- cos1 :: xis1 ~ tys1
 
-       ; let no_flattening = all isReflCo cos1
+--       ; inerts <- getTcSInerts
+--        ; let fam_eqs   = inert_funeqs inerts
 
-       ; inerts <- getTcSInerts
-       ; let fam_eqs   = inert_funeqs inerts
+       ; let flat_ty = mkTyConApp fn xis1
 
-       ; let is_cached = lookupFunEq (mkTyConApp fn xis1) fl fam_eqs
+       ; is_cached <- getCachedFlatEq fn xis1 fl WhenSolved
+                      -- Lookup if we have solved this goal already
+{-
+       ; let is_cached = {-# SCC "lookupFunEq" #-} 
+                         lookupFunEq flat_ty fl fam_eqs
+-}
 
        ; if no_flattening && isNothing is_cached then 
              canEqLeafFunEqLeft d fl eqv (fn,xis1) ty2
@@ -1089,23 +1120,24 @@ canEqLeafFunEqLeftRec d fl eqv (fn,tys1) ty2  -- eqv :: F tys1 ~ ty2
                  , Just (rhs_ty, ret_eq) <- is_cached
                  = (mkSymCo ret_eq, rhs_ty)
                  | Nothing <- is_cached -- Just flattening
-                 = (mkTyConAppCo fn cos1, mkTyConApp fn xis1)
+                 = (mkTyConAppCo fn cos1, flat_ty)
                  | Just (rhs_ty, ret_eq) <- is_cached  -- Both
                  = (mkSymCo ret_eq `mkTransCo` mkTyConAppCo fn cos1, rhs_ty)
                  | otherwise = panic "No flattening and not cached!"
-       ; delCachedEvVar eqv
+       ; delCachedEvVar eqv fl
        ; evc <- newEqVar fl final_ty ty2
        ; let new_eqv = evc_the_evvar evc
-       ; case fl of
-           Wanted {}  -> setEqBind eqv $ 
-                         mkSymCo final_co `mkTransCo` (mkEqVarLCo new_eqv)
-           Given {}   -> setEqBind new_eqv $ final_co `mkTransCo` (mkEqVarLCo eqv)
-           Derived {} -> return ()
+       ; fl' <- case fl of
+           Wanted {}  -> setEqBind eqv 
+                           (mkSymCo final_co `mkTransCo` (mkEqVarLCo new_eqv)) fl
+           Given {}   -> setEqBind new_eqv (final_co `mkTransCo` (mkEqVarLCo eqv)) fl
+           Derived {} -> return fl
        ; if isNewEvVar evc then
              if isNothing is_cached then
-                 canEqLeafFunEqLeft d fl new_eqv (fn,xis1) ty2
+                 {-# SCC "canEqLeafFunEqLeft" #-}
+                 canEqLeafFunEqLeft d fl' new_eqv (fn,xis1) ty2
              else
-                 canEq (d+1) fl new_eqv final_ty ty2
+                 canEq (d+1) fl' new_eqv final_ty ty2
          else return Stop
        }
        }
@@ -1119,34 +1151,16 @@ lookupFunEq pty fl fam_eqs = lookup_funeq pty fam_eqs
           | otherwise 
           = Nothing
 
-{- Original, not using inert family equations: 
-       ; if no_flattening then
-             canEqLeafFunEqLeft d fl eqv (fn,xis1) ty2
-         else do  -- There was flattening
-       { let (final_co, final_ty) = (mkTyConAppCo fn cos1, mkTyConApp fn xis1)
-       ; delCachedEvVar eqv
-       ; evc <- newEqVar fl final_ty ty2
-       ; let new_eqv = evc_the_evvar evc
-       ; case fl of
-           Wanted {}  -> setEqBind eqv $ mkSymCo final_co `mkTransCo` (mkEqVarLCo new_eqv)
-           Given {}   -> setEqBind new_eqv $ final_co `mkTransCo` (mkEqVarLCo eqv)
-           Derived {} -> return ()
-       ; if isNewEvVar evc then
-             canEqLeafFunEqLeft d fl new_eqv (fn,xis1) ty2
-         else return Stop 
-       }
-       }
--}
-
-
 canEqLeafFunEqLeft :: SubGoalDepth -- Depth
                    -> CtFlavor -> EqVar -> (TyCon,[Xi]) 
                    -> TcType -> TcS StopOrContinue
 -- Precondition: No more flattening is needed for the LHS
 canEqLeafFunEqLeft d fl eqv (fn,xis1) s2
- = do { traceTcS "canEqLeafFunEqLeft" $ ppr (evVarPred eqv)
-      ; (xi2,co2) <- flatten d fl s2 -- co2 :: xi2 ~ s2
-      ; let no_flattening_happened = isReflCo co2
+ = {-# SCC "canEqLeafFunEqLeft" #-}
+   do { traceTcS "canEqLeafFunEqLeft" $ ppr (evVarPred eqv)
+      ; (xi2,co2,no_flattening_happened) <- 
+          {-# SCC "flatten" #-} 
+          flatten d fl s2 -- co2 :: xi2 ~ s2
       ; if no_flattening_happened then 
             continueWith $ CFunEqCan { cc_id     = eqv
                                      , cc_flavor = fl
@@ -1154,19 +1168,21 @@ canEqLeafFunEqLeft d fl eqv (fn,xis1) s2
                                      , cc_tyargs = xis1 
                                      , cc_rhs    = xi2 
                                      , cc_depth  = d }
-        else do { delCachedEvVar eqv
-                ; evc <- newEqVar fl (mkTyConApp fn xis1) xi2
+        else do { delCachedEvVar eqv fl
+                ; evc <- 
+                    {-# SCC "newEqVar" #-}
+                    newEqVar fl (mkTyConApp fn xis1) xi2
                 ; let new_eqv = evc_the_evvar evc -- F xis1 ~ xi2 
                       new_cv  = mkEqVarLCo new_eqv
                       cv      = mkEqVarLCo eqv    -- F xis1 ~ s2
-                ; case fl of
-                    Wanted {} -> setEqBind eqv $ new_cv `mkTransCo` co2
-                    Given {}  -> setEqBind new_eqv $ cv `mkTransCo` mkSymCo co2
-                    Derived {} -> return ()
+                ; fl' <- case fl of
+                    Wanted {} -> setEqBind eqv (new_cv `mkTransCo` co2) fl 
+                    Given {}  -> setEqBind new_eqv (cv `mkTransCo` mkSymCo co2) fl
+                    Derived {} -> return fl
                 ; if isNewEvVar evc then 
                       do { continueWith $
                            CFunEqCan { cc_id = new_eqv
-                                     , cc_flavor = fl
+                                     , cc_flavor = fl'
                                      , cc_fun    = fn
                                      , cc_tyargs = xis1 
                                      , cc_rhs    = xi2 
@@ -1179,20 +1195,20 @@ canEqLeafTyVarLeftRec :: SubGoalDepth
                       -> TcTyVar -> TcType -> TcS StopOrContinue
 canEqLeafTyVarLeftRec d fl eqv tv s2              -- eqv :: tv ~ s2
   = do {  traceTcS "canEqLeafTyVarLeftRec" $ ppr (evVarPred eqv)
-       ; (xi1,co1) <- flatten d fl (mkTyVarTy tv) -- co1 :: xi1 ~ tv
-       ; if isReflCo co1 then
+       ; (xi1,co1,no_flattening) <- flatten d fl (mkTyVarTy tv) -- co1 :: xi1 ~ tv
+       ; if no_flattening then
              canEqLeafTyVarLeft d fl eqv tv s2
-         else do { delCachedEvVar eqv
+         else do { delCachedEvVar eqv fl
                  ; evc <- newEqVar fl xi1 s2  -- new_ev :: xi1 ~ s2
                  ; let new_ev = evc_the_evvar evc
-                 ; case fl of 
-                    Wanted  {} -> setEqBind eqv $ 
-                                  mkSymCo co1 `mkTransCo` mkEqVarLCo new_ev
-                    Given   {} -> setEqBind new_ev $ 
-                                  co1 `mkTransCo` mkEqVarLCo eqv
-                    Derived {} -> return ()
+                 ; fl' <- case fl of 
+                    Wanted  {} -> setEqBind eqv 
+                                    (mkSymCo co1 `mkTransCo` mkEqVarLCo new_ev) fl
+                    Given   {} -> setEqBind new_ev
+                                    (co1 `mkTransCo` mkEqVarLCo eqv) fl
+                    Derived {} -> return fl
                 ; if isNewEvVar evc then
-                      do { canEq d fl new_ev xi1 s2 }
+                      do { canEq d fl' new_ev xi1 s2 }
                   else return Stop
                  }
        }
@@ -1203,7 +1219,7 @@ canEqLeafTyVarLeft :: SubGoalDepth -- Depth
 -- Precondition LHS is fully rewritten from inerts (but not RHS)
 canEqLeafTyVarLeft d fl eqv tv s2       -- eqv : tv ~ s2
   = do { traceTcS "canEqLeafTyVarLeft" (ppr (evVarPred eqv))
-       ; (xi2, co) <- flatten d fl s2   -- Flatten RHS   co : xi2 ~ s2
+       ; (xi2, co, no_flattening_happened) <- flatten d fl s2   -- Flatten RHS   co : xi2 ~ s2
        ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv  =" <+> ppr tv
                                                      , text "s2  =" <+> ppr s2
                                                      , text "xi2 =" <+> ppr xi2]))
@@ -1215,8 +1231,9 @@ canEqLeafTyVarLeft d fl eqv tv s2       -- eqv : tv ~ s2
                = True
                | otherwise = False
        ; if is_same_tv then
-             do { delCachedEvVar eqv
-                ; when (isWanted fl) $ setEqBind eqv co 
+             do { delCachedEvVar eqv fl
+                ; when (isWanted fl) $ 
+                       do { _ <- setEqBind eqv co fl; return () }
                 ; return Stop }
          else
     do { -- Do an occurs check, and return a possibly
@@ -1229,7 +1246,6 @@ canEqLeafTyVarLeft d fl eqv tv s2       -- eqv : tv ~ s2
               = xi2_unfolded
               | otherwise = xi2
 
-       ; let no_flattening_happened = isReflCo co
 
        ; if no_flattening_happened then
              if isNothing occ_check_result then 
@@ -1242,21 +1258,21 @@ canEqLeafTyVarLeft d fl eqv tv s2       -- eqv : tv ~ s2
                                          , cc_depth  = d }
          else -- Flattening happened, in any case we have to create new variable 
               -- even if we report an occurs check error
-             do { delCachedEvVar eqv
+             do { delCachedEvVar eqv fl
                 ; evc <- newEqVar fl (mkTyVarTy tv) xi2' 
                 ; let eqv' = evc_the_evvar evc -- eqv' : tv ~ xi2'
                       cv   = mkEqVarLCo eqv    -- cv : tv ~ s2
                       cv'  = mkEqVarLCo eqv'   -- cv': tv ~ xi2'
-                 ; case fl of 
-                     Wanted {}  -> setEqBind eqv (cv' `mkTransCo` co)         -- tv ~ xi2' ~ s2
-                     Given {}   -> setEqBind eqv' (cv `mkTransCo` mkSymCo co) -- tv ~ s2 ~ xi2'
-                     Derived {} -> return ()
+                 ; fl' <- case fl of 
+                     Wanted {}  -> setEqBind eqv (cv' `mkTransCo` co) fl         -- tv ~ xi2' ~ s2
+                     Given {}   -> setEqBind eqv' (cv `mkTransCo` mkSymCo co) fl -- tv ~ s2 ~ xi2'
+                     Derived {} -> return fl
 
                  ; if isNewEvVar evc then 
                        if isNothing occ_check_result then 
                            canEqFailure d fl eqv'
                        else continueWith CTyEqCan { cc_id     = eqv'
-                                                  , cc_flavor = fl
+                                                  , cc_flavor = fl'
                                                   , cc_tyvar  = tv
                                                   , cc_rhs    = xi2' 
                                                   , cc_depth  = d }
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 5a4bf776fa..6bc5a4fcf3 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -453,6 +453,7 @@ Calling conventions
 \begin{code}
 checkCConv :: CCallConv -> TcM ()
 checkCConv CCallConv    = return ()
+checkCConv CApiConv     = return ()
 checkCConv StdCallConv  = do dflags <- getDOpts
                              let platform = targetPlatform dflags
                              unless (platformArch platform == ArchX86) $
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 4f8cdb2a77..72f64dddc9 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -280,7 +280,10 @@ zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
 -- Works for dictionaries and coercions
 -- Does not extend the ZonkEnv
 zonkEvBndr env var 
-  = do { ty <- zonkTcTypeToType env (varType var)
+  = do { let var_ty = varType var
+       ; ty <- 
+           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
+           zonkTcTypeToType env var_ty
        ; return (setVarType var ty) }
 
 zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
@@ -1103,7 +1106,8 @@ zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
 
 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
 zonkEvBinds env binds
-  = fixM (\ ~( _, new_binds) -> do
+  = {-# SCC "zonkEvBinds" #-}
+    fixM (\ ~( _, new_binds) -> do
 	 { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds)
          ; binds' <- mapBagM (zonkEvBind env1) binds
          ; return (env1, binds') })
@@ -1114,9 +1118,29 @@ zonkEvBinds env binds
 
 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
 zonkEvBind env (EvBind var term)
-  = do { var' <- zonkEvBndr env var
-       ; term' <- zonkEvTerm env term
-       ; return (EvBind var' term') }
+  -- This function has some special cases for avoiding re-zonking the
+  -- same types many types. See Note [Optimized Evidence Binding Zonking]
+  = case term of 
+      -- Fast path for reflexivity coercions:
+      EvCoercionBox co 
+        | Just ty <- isReflCo_maybe co
+        ->
+          do { zty  <- zonkTcTypeToType env ty
+             ; let var' = setVarType var (mkEqPred (zty,zty))
+             ; return (EvBind var' (EvCoercionBox (mkReflCo zty))) }
+
+      -- Fast path for variable-variable bindings 
+      -- NB: could be optimized further! (e.g. SymCo cv)
+        | Just cv <- getCoVar_maybe co 
+        -> do { let cv' = zonkIdOcc env cv -- Just lazily look up
+                    term' = EvCoercionBox (CoVarCo cv')
+                    var'  = setVarType var (varType cv')
+              ; return (EvBind var' term') }
+      -- Ugly safe and slow path
+      _ -> do { var'  <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
+              ; term' <- zonkEvTerm env term 
+              ; return (EvBind var' term')
+              }
 \end{code}
 
 %************************************************************************
@@ -1171,6 +1195,33 @@ The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and
 we have a type or a kind variable; for kind variables we just return AnyK (and
 not the ill-kinded Any BOX).
 
+Note [Optimized Evidence Binding Zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When optimising evidence binds we may come accross situations where 
+a coercion is just reflexivity: 
+      cv = ReflCo ty
+In such a case it is a waste of time to zonk both ty and the type 
+of the coercion, especially if the types involved are huge. For this
+reason this case is optimized to only zonk 'ty' and set the type of 
+the variable to be that zonked type.
+
+Another case that hurts a lot are simple coercion bindings of the form:
+      cv1 = cv2
+      cv3 = cv1
+      cv4 = cv2 
+etc. In all such cases it is very easy to just get the zonked type of 
+cv2 and use it to set the type of the LHS coercion variable without zonking
+twice. Though this case is funny, it can happen due the way that evidence 
+from spontaneously solved goals is now used.
+See Note [Optimizing Spontaneously Solved Goals] about this.
+
+NB: That these optimizations are independently useful, regardless of the 
+constraint solver strategy.
+
+DV, TODO: followup on this note mentioning new examples I will add to perf/
+
+
 \begin{code}
 mkZonkTcTyVar :: (TcTyVar -> TcM Type)	-- What to do for an *mutable Flexi* var
 	      -> (TcTyVar -> Type)	-- What to do for an immutable var
@@ -1186,9 +1237,14 @@ mkZonkTcTyVar unbound_mvar_fn unbound_ivar_fn
          FlatSkol ty    -> zonkType zonk_tv ty
          MetaTv _ ref   -> do { cts <- readMutVar ref
            		      ; case cts of    
-           		           Flexi -> do { kind <- zonkType zonk_tv (tyVarKind tv)
+           		           Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
+                                                         zonkType zonk_tv (tyVarKind tv)
                                                ; unbound_mvar_fn (setTyVarKind tv kind) }
-           		           Indirect ty -> zonkType zonk_tv ty }
+           		           Indirect ty -> do { zty <- zonkType zonk_tv ty 
+                                                     -- Small optimisation: shortern-out indirect steps
+                                                     -- so that the old type may be more easily collected.
+                                                     ; writeMutVar ref (Indirect zty)
+                                                     ; return zty } }
 
 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
 zonkTcTypeToType (ZonkEnv zonk_unbound_tyvar tv_env _id_env)
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index cf6e8c88df..ab7d815cd7 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -47,7 +47,11 @@ import Bag
 import Control.Monad ( foldM )
 import TrieMap
 
+import VarEnv
+import qualified Data.Traversable as Traversable
+
 import Control.Monad( when )
+import Pair ( pSnd )
 import UniqFM
 import FastString ( sLit ) 
 import DynFlags
@@ -104,7 +108,7 @@ solveInteractCts cts
           | Just (ev',fl') <- lookupTM pty acc_cache
           , fl' `canSolve` fl
           , isWanted fl
-          = do { setEvBind ev (EvId ev')
+          = do { _ <- setEvBind ev (EvId ev') fl
                ; return (acc_cts,acc_cache) }
           | otherwise -- If it's a given keep it in the work list, even if it exists in the cache!
           = return (ct:acc_cts, alterTM pty (\_ -> Just (ev,fl)) acc_cache)
@@ -133,10 +137,12 @@ solveInteractWanted wevs
 solveInteract :: TcS ()
 -- Returns the final InertSet in TcS, WorkList will be eventually empty.
 solveInteract
-  = do { dyn_flags <- getDynFlags
+  = {-# SCC "solveInteract" #-}
+    do { dyn_flags <- getDynFlags
        ; let max_depth = ctxtStkDepth dyn_flags
              solve_loop
-              = do { sel <- selectNextWorkItem max_depth
+              = {-# SCC "solve_loop" #-}
+                do { sel <- selectNextWorkItem max_depth
                    ; case sel of 
                       NoWorkRemaining     -- Done, successfuly (modulo frozen)
                         -> return ()
@@ -164,22 +170,14 @@ selectNextWorkItem max_depth
   = updWorkListTcS_return pick_next
   where 
     pick_next :: WorkList -> (SelectWorkItem, WorkList)
-    -- A simple priorititization of equalities (for now)
-    -- --------------------------------------------------------
-    pick_next wl@(WorkList { wl_eqs = eqs, wl_rest = rest })
-      = case (eqs,rest) of
-          ([],[])                        -- No more work
-              -> (NoWorkRemaining,wl)
-          ((ct:cts),_)
-            | cc_depth ct > max_depth  -- Depth exceeded
-            -> (MaxDepthExceeded ct,wl)
-            | otherwise                -- Equality work 
-            -> (NextWorkItem ct, wl { wl_eqs = cts })
-          ([],(ct:cts))
-            | cc_depth ct > max_depth  -- Depth exceeded
-            -> (MaxDepthExceeded ct,wl)
-            | otherwise                -- Non-equality work
-           -> (NextWorkItem ct, wl {wl_rest = cts})
+    pick_next wl = case selectWorkItem wl of
+                     (Nothing,_) 
+                         -> (NoWorkRemaining,wl)           -- No more work
+                     (Just ct, new_wl) 
+                         | cc_depth ct > max_depth         -- Depth exceeded
+                         -> (MaxDepthExceeded ct,new_wl)
+                     (Just ct, new_wl) 
+                         -> (NextWorkItem ct, new_wl)      -- New workitem and worklist
 
 runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline 
                   -> WorkItem                   -- The work item 
@@ -241,12 +239,7 @@ React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canoni
 \begin{code}
 thePipeline :: [(String,SimplifierStage)]
 thePipeline = [ ("canonicalization",        canonicalizationStage)
-                -- If ContinueWith, will be canonical and fully rewritten wrt inert eqs
-              , ("interact the inert eqs", interactWithInertEqsStage)
-                -- If ContinueWith, will be wanted/derived eq or non-eq
-                -- but can't rewrite not can be rewritten by the inerts
               , ("spontaneous solve",       spontaneousSolveStage)
-                -- If ContinueWith its not spontaneously solved equality
               , ("interact with inerts",    interactWithInertsStage)
               , ("top-level reactions",     topReactionsStage) ]
 \end{code}
@@ -297,66 +290,109 @@ spontaneousSolveStage :: SimplifierStage
 spontaneousSolveStage workItem
   = do { mSolve <- trySpontaneousSolve workItem
        ; spont_solve mSolve } 
-  where spont_solve SPCantSolve = continueWith workItem 
-        spont_solve (SPSolved workItem')
+  where spont_solve SPCantSolve 
+          | isCTyEqCan workItem                    -- Unsolved equality
+          = do { kickOutRewritableInerts workItem  -- NB: will add workItem in inerts
+               ; return Stop }
+          | otherwise
+          = continueWith workItem
+        spont_solve (SPSolved workItem')           -- Post: workItem' must be equality
           = do { bumpStepCountTcS
                ; traceFireTcS (cc_depth workItem) $
                  ptext (sLit "Spontaneous") 
                            <+> parens (ppr (cc_flavor workItem)) <+> ppr workItem
-               -- If original was /not/ given we may have to kick out now-rewritable inerts
-               ; when (not (isGivenOrSolvedCt workItem)) $
-                 kickOutRewritableInerts workItem'
-               -- Add solved guy in inerts anyway
-               ; updInertSetTcS workItem'
-               -- .. and Stop 
+
+                 -- NB: will add the item in the inerts
+               ; kickOutRewritableInerts workItem'
+               -- .. and Stop
                ; return Stop }
 
 kickOutRewritableInerts :: Ct -> TcS () 
 -- Pre:  ct is a CTyEqCan 
--- Post: the TcS monad is left with the thinner non-rewritable inerts; the 
---       rewritable end up in the worklist
-kickOutRewritableInerts ct 
-  = do { wl <- modifyInertTcS (kick_out_rewritable ct)
-
-         -- Rewrite the rewritable solved on the spot and stick them back in the inerts
-
-{- DV: I am commenting out the solved story altogether because I did not see any performance
-       improvement compared to just kicking out the solved ones any way. In fact there were
-       situations where performance got worse.
-
-       ; let subst = unitVarEnv (cc_tyvar ct) (ct, mkEqVarLCo (cc_id ct))
-             inscope = mkInScopeSet $ tyVarsOfCt ct
-       ; solved_rewritten <- mapBagM (rewrite_solved (subst,inscope)) solved_out
-       ; _unused <- modifyInertTcS (add_new_solveds solved_rewritten)
-      
--}
+-- Post: The TcS monad is left with the thinner non-rewritable inerts; but which
+--       contains the new constraint.
+--       The rewritable end up in the worklist
+kickOutRewritableInerts ct
+  = {-# SCC "kickOutRewritableInerts" #-}
+    do { (wl,ieqs) <- {-# SCC "kick_out_rewritable" #-}
+                      modifyInertTcS (kick_out_rewritable ct)
+
+       -- Step 1: Rewrite as many of the inert_eqs on the spot! 
+       -- NB: if it is a solved constraint just use the cached evidence
+       ; let ct_coercion 
+               | Just (GivenSolved (Just (EvCoercionBox co))) <- isGiven_maybe (cc_flavor ct)
+               = co 
+               | otherwise 
+               = mkEqVarLCo (cc_id ct)
+
+       ; new_ieqs <- {-# SCC "rewriteInertEqsFromInertEq" #-}
+                     rewriteInertEqsFromInertEq (cc_tyvar ct,ct_coercion, cc_flavor ct) ieqs
+       ; modifyInertTcS (\is -> ((), is { inert_eqs = new_ieqs }))
+
+       -- Step 2: Add the new guy in
+       ; updInertSetTcS ct
+
        ; traceTcS "Kick out" (ppr ct $$ ppr wl)
        ; updWorkListTcS (unionWorkList wl) }
-{- 
-  where rewrite_solved inert_eqs solved_ct 
-          = do { (new_ev,_) <- rewriteFromInertEqs inert_eqs fl ev
-               ; mk_canonical new_ev }
-          where fl = cc_flavor solved_ct
-                ev = cc_id solved_ct
-                d  = cc_depth solved_ct
-                mk_canonical new_ev
-                  -- A bit of an overkill to call the canonicalizer, but ok ...
-                  = do { let new_pty = evVarPred new_ev
-                       ; r <- canEvVar new_ev (classifyPredType new_pty) d fl
-                       ; case r of
-                           Stop -> pprPanic "kickOutRewritableInerts" $ 
-                                   vcat [ text "Should never Stop, solved constraint IS canonical!"
-                                        , text "Orig (solved)     =" <+> ppr solved_ct
-                                        , text "Rewritten (solved)=" <+> ppr new_pty ]
-                           ContinueWith ct -> return ct }
-        add_new_solveds cts is = ((), is { inert_solved = new_solved })
-           where orig_solveds     = inert_solved is
-                 do_one slvmap ct = let ct_key = mkPredKeyForTypeMap ct
-                                    in alterTM ct_key (\_ -> Just ct) slvmap
-                 new_solved       = foldlBag do_one orig_solveds cts
--}
-
-kick_out_rewritable :: Ct -> InertSet -> (WorkList,InertSet)
+
+rewriteInertEqsFromInertEq :: (TcTyVar,Coercion, CtFlavor) -- A new substitution
+                           -> TyVarEnv (Ct,Coercion)       -- All inert equalities
+                           -> TcS (TyVarEnv (Ct,Coercion)) -- The new inert equalities
+rewriteInertEqsFromInertEq (subst_tv,subst_co, subst_fl) ieqs
+-- The goal: traverse the inert equalities and rewrite some of them, dropping some others
+-- back to the worklist. This is delicate, see Note [Delicate equality kick-out]
+ = do { mieqs <- Traversable.mapM do_one ieqs 
+      ; traceTcS "Original inert equalities:" (ppr ieqs)
+      ; let flatten_justs elem venv
+              | Just (act,aco) <- elem = extendVarEnv venv (cc_tyvar act) (act,aco)
+              | otherwise = venv                                     
+            final_ieqs = foldVarEnv flatten_justs emptyVarEnv mieqs
+      ; traceTcS "Remaining inert equalities:" (ppr final_ieqs)
+      ; return final_ieqs }
+
+ where do_one (ct,inert_co)
+         | subst_fl `canRewrite` fl && (subst_tv `elemVarSet` tyVarsOfCt ct) 
+                                      -- Annoyingly inefficient, but we can't simply check 
+                                      -- that isReflCo co because of cached solved ReflCo evidence.
+         = if fl `canRewrite` subst_fl then 
+               -- If also the inert can rewrite the subst it's totally safe 
+               -- to rewrite on the spot
+               do { (ct',inert_co') <- rewrite_on_the_spot (ct,inert_co)
+                  ; return $ Just (ct',inert_co') }
+           else -- We have to throw inert back to worklist for occurs checks 
+              do { updWorkListTcS (extendWorkListEq ct)
+                 ; return Nothing }
+         | otherwise -- Just keep it there
+         = return $ Just (ct,inert_co)
+         where 
+           rewrite_on_the_spot (ct,_inert_co)
+             = do { let rhs' = pSnd (liftedCoercionKind co)
+                  ; delCachedEvVar ev fl
+                  ; evc <- newEqVar fl (mkTyVarTy tv) rhs'
+                  ; let ev' = evc_the_evvar evc
+                  ; let evco' = mkEqVarLCo ev' 
+                  ; fl' <- if isNewEvVar evc then
+                               do { case fl of 
+                                      Wanted {} 
+                                        -> setEqBind ev (evco' `mkTransCo` mkSymCo co) fl
+                                      Given {} 
+                                        -> setEqBind ev' (mkEqVarLCo ev `mkTransCo` co) fl
+                                      Derived {}
+                                        -> return fl }
+                           else
+                               if isWanted fl then 
+                                   setEqBind ev (evco' `mkTransCo` mkSymCo co) fl
+                               else return fl
+                  ; let ct' = ct { cc_id = ev', cc_flavor = fl', cc_rhs = rhs' }
+                  ; return (ct',evco') }
+           ev  = cc_id ct
+           fl  = cc_flavor ct
+           tv  = cc_tyvar ct
+           rhs = cc_rhs ct
+           co  = liftCoSubstWith [subst_tv] [subst_co] rhs
+
+kick_out_rewritable :: Ct -> InertSet -> ((WorkList,TyVarEnv (Ct,Coercion)), InertSet)
+-- Returns ALL equalities, to be dealt with later
 kick_out_rewritable ct (IS { inert_eqs    = eqmap
                            , inert_eq_tvs = inscope
                            , inert_dicts  = dictmap
@@ -365,14 +401,14 @@ kick_out_rewritable ct (IS { inert_eqs    = eqmap
                            , inert_irreds = irreds
                            , inert_frozen = frozen
                            } )
-  = (kicked_out, remaining)
+  = ((kicked_out, eqmap), remaining)
   where
-
-    kicked_out = WorkList { wl_eqs  = eqs_out ++ bagToList feqs_out
-                          , wl_rest = bagToList (fro_out `andCts` dicts_out 
-                                        `andCts` ips_out `andCts` irs_out) }
+    kicked_out = WorkList { wl_eqs    = []
+                          , wl_funeqs = bagToList feqs_out
+                          , wl_rest   = bagToList (fro_out `andCts` dicts_out 
+                                          `andCts` ips_out `andCts` irs_out) }
   
-    remaining = IS { inert_eqs = eqs_in
+    remaining = IS { inert_eqs = emptyVarEnv
                    , inert_eq_tvs = inscope -- keep the same, safe and cheap
                    , inert_dicts = dicts_in
                    , inert_ips = ips_in
@@ -383,20 +419,46 @@ kick_out_rewritable ct (IS { inert_eqs    = eqmap
 
     fl = cc_flavor ct
     tv = cc_tyvar ct
+                               
+    (ips_out,   ips_in)     = partitionCCanMap rewritable ipmap
 
-    (eqs_out,   eqs_in)   = partitionEqMap rewritable eqmap
-    (ips_out,   ips_in)   = partitionCCanMap rewritable ipmap 
-
-    (feqs_out,  feqs_in)  = partitionCtTypeMap rewritable funeqmap
-    (dicts_out, dicts_in) = partitionCCanMap rewritable dictmap
+    (feqs_out,  feqs_in)    = partitionCtTypeMap rewritable funeqmap
+    (dicts_out, dicts_in)   = partitionCCanMap rewritable dictmap
 
     (irs_out,   irs_in)   = partitionBag rewritable irreds
     (fro_out,   fro_in)   = partitionBag rewritable frozen
-    rewritable ct = (fl `canRewrite` cc_flavor ct) && 
+
+    rewritable ct = (fl `canRewrite` cc_flavor ct)  &&
                     (tv `elemVarSet` tyVarsOfCt ct)
+\end{code}
+
+Note [Delicate equality kick-out]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+
+Delicate:
+When kicking out rewritable constraints, it would be safe to simply
+kick out all rewritable equalities, but instead we only kick out those
+that, when rewritten, may result in occur-check errors. We rewrite the
+rest on the spot. Example:
+
+          WorkItem =   [S] a ~ b
+          Inerts   = { [W] b ~ [a] }
+Now at this point the work item cannot be further rewritten by the
+inert (due to the weaker inert flavor), so we are examining if we can
+instead rewrite the inert from the workitem. But if we rewrite it on
+the spot we have to recanonicalize because of the danger of occurs
+errors.  On the other hand if the inert flavor was just as powerful or
+more powerful than the workitem flavor, the work-item could not have
+reached this stage (because it would have already been rewritten by
+the inert).
 
+The coclusion is: we kick out the 'dangerous' equalities that may
+require recanonicalization (occurs checks) and the rest we rewrite
+unconditionally without further checks, on-the-spot with function
+rewriteInertEqsFromInertEq.
 
-                             
+
+\begin{code}
 data SPSolveResult = SPCantSolve
                    | SPSolved WorkItem 
 
@@ -465,21 +527,7 @@ trySpontaneousEqTwoWay d eqv gw tv1 tv2
     k1 = tyVarKind tv1
     k2 = tyVarKind tv2
     nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
-{-
--- Previous code below (before kind polymorphism and unification):
-  -- | k1 `isSubKind` k2
-  -- , nicer_to_update_tv2 = solveWithIdentity eqv gw tv2 (mkTyVarTy tv1)
-  -- | k2 `isSubKind` k1 
-  -- = solveWithIdentity eqv gw tv1 (mkTyVarTy tv2)
-  -- | otherwise -- None is a subkind of the other, but they are both touchable! 
-  -- = return SPCantSolve
-  --   -- do { addErrorTcS KindError gw (mkTyVarTy tv1) (mkTyVarTy tv2)
-  --   --   ; return SPError }
-  -- where
-  --   k1 = tyVarKind tv1
-  --   k2 = tyVarKind tv2
-  --   nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
--}
+
 \end{code}
 
 Note [Kind errors] 
@@ -565,7 +613,7 @@ solveWithIdentity :: SubGoalDepth
 --        workItem = the new Given constraint
 solveWithIdentity d eqv wd tv xi 
   = do { traceTcS "Sneaky unification:" $ 
-                       vcat [text "Coercion variable:  " <+> ppr wd, 
+                       vcat [text "Coercion variable:  " <+> ppr eqv <+> ppr wd, 
                              text "Coercion:           " <+> pprEq (mkTyVarTy tv) xi,
                              text "Left  Kind is     : " <+> ppr (typeKind (mkTyVarTy tv)),
                              text "Right Kind is     : " <+> ppr (typeKind xi)
@@ -574,36 +622,16 @@ solveWithIdentity d eqv wd tv xi
        ; setWantedTyBind tv xi
        ; let refl_xi = mkReflCo xi
 
-       ; let solved_fl = mkSolvedFlavor wd UnkSkol 
-       ; eqv_given <- newGivenEqVar solved_fl (mkTyVarTy tv) xi refl_xi
+       ; let solved_fl = mkSolvedFlavor wd UnkSkol (EvCoercionBox refl_xi) 
+       ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi refl_xi
 
-       ; when (isWanted wd) (setEqBind eqv refl_xi)
+       ; when (isWanted wd) $ do { _ <- setEqBind eqv refl_xi wd; return () }
            -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)'
        ; return $ SPSolved (CTyEqCan { cc_id     = eqv_given
                                      , cc_flavor = solved_fl
                                      , cc_tyvar  = tv, cc_rhs = xi, cc_depth = d }) }
 \end{code}
 
-*********************************************************************************
-*                                                                               *
-*                         Interact with inert equalities                        *
-*                                                                               *
-*********************************************************************************
-
-\begin{code}
-
-interactWithInertEqsStage  :: WorkItem -> TcS StopOrContinue
-interactWithInertEqsStage  ct 
-  | isCTyEqCan ct
-  = do { kickOutRewritableInerts ct
-       ; if isGivenOrSolved (cc_flavor ct) then updInertSetTcS ct >> return Stop
-         else continueWith ct } -- If wanted or derived we may spontaneously solve him
-  | isCNonCanonical ct
-  = pprPanic "Interact with inerts eqs stage met non-canonical constraint!" (ppr ct)
-  | otherwise
-  = continueWith ct
-\end{code}
-
 
 *********************************************************************************
 *                                                                               * 
@@ -779,9 +807,8 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i
            Given   {} -> pprPanic "Unexpected given IP" (ppr workItem)
            Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem)
            Wanted  {} ->
-               do { setEvBind (cc_id workItem) $ 
-                    mkEvCast id1 (mkSymCo (mkTyConAppCo (ipTyCon nm1) [mkEqVarLCo (evc_the_evvar eqv)]))
-                    -- DV: Changing: used to be (mkSymCo (mkEqVarLCo eqv))
+               do { _ <- setEvBind (cc_id workItem) 
+                            (mkEvCast id1 (mkSymCo (mkTyConAppCo (ipTyCon nm1) [mkEqVarLCo (evc_the_evvar eqv)]))) wfl
                   ; irWorkItemConsumed "IP/IP (solved by rewriting)" } }
 
 doInteractWithInert (CFunEqCan { cc_id = eqv1, cc_flavor = fl1, cc_fun = tc1
@@ -789,13 +816,13 @@ doInteractWithInert (CFunEqCan { cc_id = eqv1, cc_flavor = fl1, cc_fun = tc1
                     (CFunEqCan { cc_id = eqv2, cc_flavor = fl2, cc_fun = tc2
                                , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 })
   | lhss_match  
-  , Just GivenSolved <- isGiven_maybe fl1 -- Inert is solved and we can simply ignore it
+  , Just (GivenSolved {}) <- isGiven_maybe fl1 -- Inert is solved and we can simply ignore it
                                           -- when workitem is given/solved
   , isGivenOrSolved fl2
   = irInertConsumed "FunEq/FunEq"
   | lhss_match 
-  , Just GivenSolved <- isGiven_maybe fl2 -- Workitem is solved and we can ignore it when
-                                          -- the inert is given/solved
+  , Just (GivenSolved {}) <- isGiven_maybe fl2 -- Workitem is solved and we can ignore it when
+                                               -- the inert is given/solved
   , isGivenOrSolved fl1                 
   = irWorkItemConsumed "FunEq/FunEq" 
   | fl1 `canSolve` fl2 && lhss_match
@@ -820,40 +847,40 @@ rewriteEqLHS :: WhichComesFromInert -> (EqVar,Xi) -> (EqVar,SubGoalDepth,CtFlavo
 -- We have an option of creating new work (xi1 ~ xi2) OR (xi2 ~ xi1), 
 --    See Note [Efficient Orientation] for that 
 rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2) 
-  = do { delCachedEvVar eqv2 -- Similarly to canonicalization!
+  = do { delCachedEvVar eqv2 gw -- Similarly to canonicalization!
        ; evc <- newEqVar gw xi2 xi1
        ; let eqv2' = evc_the_evvar evc
-       ; case gw of 
+       ; gw' <- case gw of 
            Wanted {} 
-               -> setEqBind eqv2 $ 
-                  mkEqVarLCo eqv1 `mkTransCo` mkSymCo (mkEqVarLCo eqv2')
-           Given {}  
-               -> setEqBind eqv2' $ 
-                  mkSymCo (mkEqVarLCo eqv2) `mkTransCo` mkEqVarLCo eqv1
+               -> setEqBind eqv2 
+                    (mkEqVarLCo eqv1 `mkTransCo` mkSymCo (mkEqVarLCo eqv2')) gw
+           Given {}
+               -> setEqBind eqv2'
+                    (mkSymCo (mkEqVarLCo eqv2) `mkTransCo` mkEqVarLCo eqv1) gw
            Derived {} 
-               -> return ()
+               -> return gw
        ; when (isNewEvVar evc) $ 
               updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id     = eqv2'
-                                                              , cc_flavor = gw
+                                                              , cc_flavor = gw'
                                                               , cc_depth  = d } ) ) }
 
 rewriteEqLHS RightComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2) 
-  = do { delCachedEvVar eqv2 -- Similarly to canonicalization!
+  = do { delCachedEvVar eqv2 gw -- Similarly to canonicalization!
        ; evc <- newEqVar gw xi1 xi2
        ; let eqv2' = evc_the_evvar evc
-       ; case gw of
+       ; gw' <- case gw of
            Wanted {} 
-               -> setEqBind eqv2 $ 
-                  mkEqVarLCo eqv1 `mkTransCo` mkEqVarLCo eqv2'
+               -> setEqBind eqv2
+                    (mkEqVarLCo eqv1 `mkTransCo` mkEqVarLCo eqv2') gw
            Given {}  
-               -> setEqBind eqv2' $
-                  mkSymCo (mkEqVarLCo eqv1) `mkTransCo` mkEqVarLCo eqv2
+               -> setEqBind eqv2'
+                    (mkSymCo (mkEqVarLCo eqv1) `mkTransCo` mkEqVarLCo eqv2) gw
            Derived {} 
-               -> return ()
+               -> return gw
 
        ; when (isNewEvVar evc) $
               updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id = eqv2'
-                                                              , cc_flavor = gw
+                                                              , cc_flavor = gw'
                                                               , cc_depth  = d } ) ) }
 
 solveOneFromTheOther :: String             -- Info 
@@ -872,14 +899,14 @@ solveOneFromTheOther info (ev_term,ifl) workItem
 		  -- so it's safe to continue on from this point
   = irInertConsumed ("Solved[DI] " ++ info)
   
-  | Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl
+  | Just (GivenSolved {}) <- isGiven_maybe ifl, isGivenOrSolved 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 ev_term
+    do { when (isWanted wfl) $ do { _ <- setEvBind wid ev_term wfl; return () }
            -- Overwrite the binding, if one exists
 	   -- If both are Given, we already have evidence; no need to duplicate
        ; irWorkItemConsumed ("Solved " ++ info) }
@@ -1331,30 +1358,32 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc)
          doSolveFromInstance wtvs ev_term workItem
             | null wtvs
             = do { traceTcS "doTopReact/found nullary instance for" (ppr (cc_id workItem))
-                 ; setEvBind (cc_id workItem) ev_term
+                 ; _ <- setEvBind (cc_id workItem) ev_term fl
                  ; return $ 
                    SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" 
                               , tir_new_item = Stop } } -- Don't put him in the inerts
             | otherwise 
             = do { traceTcS "doTopReact/found non-nullary instance for" $ 
                    ppr (cc_id workItem)
-                 ; setEvBind (cc_id workItem) ev_term 
+                 ; _ <- setEvBind (cc_id workItem) ev_term fl
                         -- Solved and new wanted work produced, you may cache the 
                         -- (tentatively solved) dictionary as Solved given.
-                 ; let solved = workItem { cc_flavor = solved_fl }
-                       solved_fl = mkSolvedFlavor fl UnkSkol
+--                 ; let _solved = workItem { cc_flavor = solved_fl }
+--                       solved_fl = mkSolvedFlavor fl UnkSkol
                  ; let ct_from_wev (EvVarX v fl)
                            = CNonCanonical { cc_id = v, cc_flavor = Wanted fl
                                            , cc_depth  = cc_depth workItem + 1 }
                        wtvs_cts = map ct_from_wev wtvs
                  ; updWorkListTcS (appendWorkListCt wtvs_cts)
-                 ; return $ 
+                 ; return $
                    SomeTopInt { tir_rule     = "Dict/Top (solved, more work)"
-                              , tir_new_item = ContinueWith solved } } -- Cache in inerts the Solved item
+                              , tir_new_item = Stop }
+                 }
+--                              , tir_new_item = ContinueWith solved } } -- Cache in inerts the Solved item
 
 -- Type functions
 doTopReact _inerts (CFunEqCan { cc_flavor = fl })
-  | Just GivenSolved <- isGiven_maybe fl
+  | Just (GivenSolved {}) <- isGiven_maybe fl
   = return NoTopInt -- If Solved, no more interactions should happen
 
 -- Otherwise, it's a Given, Derived, or Wanted
@@ -1375,25 +1404,29 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl
                    ; case fl of
                        Wanted {} -> do { evc <- newEqVar fl rhs_ty xi -- Wanted version
                                        ; let eqv' = evc_the_evvar evc
-                                       ; setEqBind eqv (coe `mkTransCo` mkEqVarLCo eqv')
+                                       ; let coercion = coe `mkTransCo` mkEqVarLCo eqv'
+                                       ; _ <- setEqBind eqv coercion fl
                                        ; when (isNewEvVar evc) $ 
                                             (let ct = CNonCanonical { cc_id = eqv'
                                                                     , cc_flavor = fl 
                                                                     , cc_depth = cc_depth workItem + 1} 
                                              in updWorkListTcS (extendWorkListEq ct))
 
-                                       ; let solved = workItem { cc_flavor = solved_fl }
-                                             solved_fl = mkSolvedFlavor fl UnkSkol
+                                       ; let _solved   = workItem { cc_flavor = solved_fl }
+                                             solved_fl = mkSolvedFlavor fl UnkSkol (EvCoercionBox coercion)
+
+                                       ; updateFlatCache eqv solved_fl tc args xi WhenSolved
 
                                        ; return $ 
                                          SomeTopInt { tir_rule = "Fun/Top (solved, more work)"
-                                                    , tir_new_item = ContinueWith solved } } 
-                       -- Cache in inerts the Solved item
+                                                    , tir_new_item = Stop } }
+                                                  --  , tir_new_item = ContinueWith solved } }
+                                                     -- Cache in inerts the Solved item
 
-                       Given {} -> do { eqv' <- newGivenEqVar fl xi rhs_ty $ 
-                                                mkSymCo (mkEqVarLCo eqv) `mkTransCo` coe
+                       Given {} -> do { (fl',eqv') <- newGivenEqVar fl xi rhs_ty $ 
+                                                         mkSymCo (mkEqVarLCo eqv) `mkTransCo` coe
                                       ; let ct = CNonCanonical { cc_id = eqv'
-                                                               , cc_flavor = fl
+                                                               , cc_flavor = fl'
                                                                , cc_depth = cc_depth workItem + 1}  
                                       ; updWorkListTcS (extendWorkListEq ct) 
 
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 174939688c..b383563311 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -1435,6 +1435,7 @@ tcRnExpr hsc_env ictxt rdr_expr
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
     ((_tc_expr, res_ty), lie)	<- captureConstraints (tcInferRho rn_expr) ;
     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ 
+                                      {-# SCC "simplifyInfer" #-}
                                       simplifyInfer True {- Free vars are closed -}
                                                     False {- No MR for now -}
                                                     [(fresh_it, res_ty)]
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index fbe3a2fc7f..845eaceb7b 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -1011,7 +1011,7 @@ emitWantedCts = mapBagM_ emit_wanted_ct
           | v <- cc_id ct 
           , Wanted loc <- cc_flavor ct 
           = emitFlat (EvVarX v loc)
-          | otherwise = panic "emitWantecCts: can't emit non-wanted!"
+          | otherwise = panic "emitWantedCts: can't emit non-wanted!"
 
 emitImplication :: Implication -> TcM ()
 emitImplication ct
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index da2c8981ed..12f3184aa4 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -71,7 +71,7 @@ module TcRnTypes(
 	SkolemInfo(..),
 
         CtFlavor(..), pprFlavorArising, isWanted, 
-        isGivenOrSolved, isGiven_maybe,
+        isGivenOrSolved, isGiven_maybe, isSolved,
         isDerived,
 
 	-- Pretty printing
@@ -1210,14 +1210,17 @@ data CtFlavor
 
 data GivenKind
   = GivenOrig   -- Originates in some given, such as signature or pattern match
-  | GivenSolved -- Is given as result of being solved, maybe provisionally on
-                -- some other wanted constraints. 
+  | GivenSolved (Maybe EvTerm) 
+                -- Is given as result of being solved, maybe provisionally on
+                -- some other wanted constraints. We cache the evidence term 
+                -- sometimes here as well /as well as/ in the EvBinds, 
+                -- see Note [Optimizing Spontaneously Solved Coercions]
 
 instance Outputable CtFlavor where
-  ppr (Given _ GivenOrig)   = ptext (sLit "[G]")
-  ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
-  ppr (Wanted {})           = ptext (sLit "[W]")
-  ppr (Derived {})          = ptext (sLit "[D]") 
+  ppr (Given _ GivenOrig)        = ptext (sLit "[G]")
+  ppr (Given _ (GivenSolved {})) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
+  ppr (Wanted {})                = ptext (sLit "[W]")
+  ppr (Derived {})               = ptext (sLit "[D]")
 
 pprFlavorArising :: CtFlavor -> SDoc
 pprFlavorArising (Derived wl)   = pprArisingAt wl
@@ -1232,6 +1235,10 @@ isGivenOrSolved :: CtFlavor -> Bool
 isGivenOrSolved (Given {}) = True
 isGivenOrSolved _ = False
 
+isSolved :: CtFlavor -> Bool
+isSolved (Given _ (GivenSolved {})) = True
+isSolved _ = False
+
 isGiven_maybe :: CtFlavor -> Maybe GivenKind 
 isGiven_maybe (Given _ gk) = Just gk
 isGiven_maybe _            = Nothing
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 7d3ee73f6b..aee0877c75 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -14,7 +14,7 @@ module TcSMonad (
     WorkList(..), isEmptyWorkList, emptyWorkList,
     workListFromEq, workListFromNonEq, workListFromCt, 
     extendWorkListEq, extendWorkListNonEq, extendWorkListCt, 
-    appendWorkListCt, appendWorkListEqs, unionWorkList,
+    appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem,
 
     getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted,
 
@@ -47,8 +47,6 @@ module TcSMonad (
 
        -- Setting evidence variables 
     setEqBind,
-    setIPBind,
-    setDictBind,
     setEvBind,
 
     setWantedTyBind,
@@ -62,7 +60,7 @@ module TcSMonad (
 
         -- Inerts 
     InertSet(..), 
-    getInertEqs, rewriteFromInertEqs, liftInertEqsTy,
+    getInertEqs, liftInertEqsTy,
     emptyInert, getTcSInerts, updInertSet, extractUnsolved,
     extractUnsolvedTcS, modifyInertTcS,
     updInertSetTcS, partitionCCanMap, partitionEqMap,
@@ -125,7 +123,7 @@ import Bag
 import MonadUtils
 import VarSet
 
-import Pair ( pSnd )
+-- import Pair ( pSnd )
 import FastString
 import Util
 
@@ -207,17 +205,22 @@ better rewrite it as much as possible before reporting it as an error to the use
 \begin{code}
 
 -- See Note [WorkList]
-data WorkList = WorkList { wl_eqs  :: [Ct], wl_rest :: [Ct] }
+data WorkList = WorkList { wl_eqs  :: [Ct], wl_funeqs :: [Ct], wl_rest :: [Ct] }
 
 
 unionWorkList :: WorkList -> WorkList -> WorkList
 unionWorkList new_wl orig_wl = 
-   WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl
-            , wl_rest = wl_rest new_wl ++ wl_rest orig_wl }
+   WorkList { wl_eqs    = wl_eqs new_wl ++ wl_eqs orig_wl
+            , wl_funeqs = wl_funeqs new_wl ++ wl_funeqs orig_wl
+            , wl_rest   = wl_rest new_wl ++ wl_rest orig_wl }
 
 extendWorkListEq :: Ct -> WorkList -> WorkList
 -- Extension by equality
-extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
+extendWorkListEq ct wl 
+  | Just {} <- isCFunEqCan_Maybe ct
+  = wl { wl_funeqs = ct : wl_funeqs wl }
+  | otherwise
+  = wl { wl_eqs = ct : wl_eqs wl }
 
 extendWorkListNonEq :: Ct -> WorkList -> WorkList
 -- Extension by non equality
@@ -238,25 +241,36 @@ appendWorkListEqs :: [Ct] -> WorkList -> WorkList
 appendWorkListEqs cts wl = foldr extendWorkListEq wl cts
 
 isEmptyWorkList :: WorkList -> Bool
-isEmptyWorkList wl = null (wl_eqs wl) &&  null (wl_rest wl)
+isEmptyWorkList wl 
+  = null (wl_eqs wl) &&  null (wl_rest wl) && null (wl_funeqs wl)
 
 emptyWorkList :: WorkList
-emptyWorkList = WorkList { wl_eqs  = [], wl_rest = [] }
+emptyWorkList = WorkList { wl_eqs  = [], wl_rest = [], wl_funeqs = []}
 
 workListFromEq :: Ct -> WorkList
-workListFromEq ct = WorkList { wl_eqs = [ct], wl_rest = [] }
+workListFromEq ct = extendWorkListEq ct emptyWorkList
 
 workListFromNonEq :: Ct -> WorkList
-workListFromNonEq ct = WorkList { wl_eqs = [], wl_rest = [ct] }
+workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList
 
 workListFromCt :: Ct -> WorkList
 -- Agnostic 
 workListFromCt ct | isLCoVar (cc_id ct) = workListFromEq ct 
                   | otherwise           = workListFromNonEq ct
 
+
+selectWorkItem :: WorkList -> (Maybe Ct, WorkList)
+selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
+  = case (eqs,feqs,rest) of
+      (ct:cts,_,_)     -> (Just ct, wl { wl_eqs    = cts })
+      (_,(ct:cts),_)   -> (Just ct, wl { wl_funeqs = cts })
+      (_,_,(ct:cts))   -> (Just ct, wl { wl_rest   = cts })
+      (_,_,_)          -> (Nothing,wl)
+
 -- Pretty printing 
 instance Outputable WorkList where 
   ppr wl = vcat [ text "WorkList (eqs)   = " <+> ppr (wl_eqs wl)
+                , text "WorkList (funeqs)= " <+> ppr (wl_funeqs wl)
                 , text "WorkList (rest)  = " <+> ppr (wl_rest wl)
                 ]
 
@@ -475,22 +489,25 @@ updInertSet :: InertSet -> AtomicInert -> InertSet
 -- Add a new inert element to the inert set. 
 updInertSet is item 
   | isCTyEqCan item                     
-  = let upd_err a b = pprPanic "updInertSet" $ 
-                      vcat [text "Multiple inert equalities:", ppr a, ppr b]
+  = let upd_err a b = pprPanic "updInertSet" $
+                      vcat [ text "Multiple inert equalities:"
+                           , text "Old (already inert):" <+> ppr a
+                           , text "Trying to insert   :" <+> ppr b
+                           ]
+                           
+        -- If evidence is cached, pick it up from the flavor!
+        coercion 
+          | Just (GivenSolved (Just (EvCoercionBox co))) <- isGiven_maybe (cc_flavor item)
+          = co
+          | otherwise 
+          = mkEqVarLCo (cc_id item)
+
         eqs'     = extendVarEnv_C upd_err (inert_eqs is)
                                           (cc_tyvar item)
-                                          (item, mkEqVarLCo (cc_id item))
+                                          (item, coercion)
         inscope' = extendInScopeSetSet (inert_eq_tvs is) (tyVarsOfCt item)
     in is { inert_eqs = eqs', inert_eq_tvs = inscope' }
 
-{-
-       -- /Solved/ non-equalities go to the solved map
-  | Just GivenSolved <- isGiven_maybe (cc_flavor item)
-  = let pty = mkPredKeyForTypeMap item
-        solved_orig = inert_solved is
-    in is { inert_solved = alterTM pty (\_ -> Just item) solved_orig }
--}
-
   | Just x  <- isCIPCan_Maybe item      -- IP 
   = is { inert_ips   = updCCanMap (x,item) (inert_ips is) }  
   | isCIrredEvCan item                  -- Presently-irreducible evidence
@@ -660,11 +677,11 @@ combineCtLoc (Derived loc ) _  = loc
 combineCtLoc _ (Derived loc )  = loc
 combineCtLoc _ _ = panic "combineCtLoc: both given"
 
-mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor
 -- To be called when we actually solve a wanted/derived (perhaps leaving residual goals)
-mkSolvedFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenSolved
-mkSolvedFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk) GivenSolved
-mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
+mkSolvedFlavor (Wanted  loc) sk  evterm  = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm))
+mkSolvedFlavor (Derived loc) sk  evterm  = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm))
+mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl
 
 mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
 mkGivenFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
@@ -1050,8 +1067,8 @@ getTcEvBindsMap
        ; wrapTcS $ TcM.readTcRef ev_ref }
 
 
-setEqBind :: EqVar -> LCoercion -> TcS () 
-setEqBind eqv co = setEvBind eqv (EvCoercionBox co)
+setEqBind :: EqVar -> LCoercion -> CtFlavor -> TcS CtFlavor
+setEqBind eqv co fl = setEvBind eqv (EvCoercionBox co) fl
 
 setWantedTyBind :: TcTyVar -> TcType -> TcS () 
 -- Add a type binding
@@ -1067,15 +1084,11 @@ setWantedTyBind tv ty
                        , text "Old value =" <+> ppr (lookupVarEnv_NF ty_binds tv)]
             ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } }
 
-setIPBind :: EvVar -> EvTerm -> TcS () 
-setIPBind = setEvBind 
 
-setDictBind :: EvVar -> EvTerm -> TcS () 
-setDictBind = setEvBind 
-
-setEvBind :: EvVar -> EvTerm -> TcS () 
--- Internal
-setEvBind ev t
+setEvBind :: EvVar -> EvTerm -> CtFlavor -> TcS CtFlavor
+-- If the flavor is Solved, we cache the new evidence term inside the returned flavor
+-- see Note [Optimizing Spontaneously Solved Coercions]
+setEvBind ev t fl
   = do { tc_evbinds <- getTcEvBinds
        ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t
 
@@ -1084,6 +1097,11 @@ setEvBind ev t
        ; let cycle = any (reaches binds) (evterm_evs t)
        ; when cycle (fail_if_co_loop binds)
 #endif
+       ; return $ 
+         case fl of 
+           Given gl (GivenSolved _) 
+               -> Given gl (GivenSolved (Just t))
+           _   -> fl
        }
 
 #ifdef DEBUG
@@ -1110,6 +1128,51 @@ setEvBind ev t
         evterm_evs (EvTupleMk evs)     = evs
 #endif
 
+\end{code}
+Note [Optimizing Spontaneously Solved Coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+
+Spontaneously solved coercions such as alpha := tau used to be bound as everything else
+in the evidence binds. Subsequently they were used for rewriting other wanted or solved
+goals. For instance: 
+
+WorkItem = [S] g1 : a ~ tau
+Inerts   = [S] g2 : b ~ [a]
+           [S] g3 : c ~ [(a,a)]
+
+Would result, eventually, after the workitem rewrites the inerts, in the
+following evidence bindings:
+
+        g1 = ReflCo tau
+        g2 = ReflCo [a]
+        g3 = ReflCo [(a,a)]
+        g2' = g2 ; [g1] 
+        g3' = g3 ; [(g1,g1)]
+
+This ia annoying because it puts way too much stress to the zonker and
+desugarer, since we /know/ at the generation time (spontaneously
+solving) that the evidence for a particular evidence variable is the
+identity.
+
+For this reason, our solution is to cache inside the GivenSolved
+flavor of a constraint the term which is actually solving this
+constraint. Whenever we perform a setEvBind, a new flavor is returned
+so that if it was a GivenSolved to start with, it remains a
+GivenSolved with a new evidence term inside. Then, when we use solved
+goals to rewrite other constraints we simply use whatever is in the
+GivenSolved flavor and not the constraint cc_id.
+
+In our particular case we'd get the following evidence bindings, eventually: 
+
+       g1 = ReflCo tau
+       g2 = ReflCo [a]
+       g3 = ReflCo [(a,a)]
+       g2'= ReflCo [a]
+       g3'= ReflCo [(a,a)]
+
+Since we use smart constructors to get rid of g;ReflCo t ~~> g etc.
+
+\begin{code}
 
 
 warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
@@ -1267,11 +1330,23 @@ newEvVar :: CtFlavor -> TcPredType -> TcS EvVarCreated
 --     the call sites for this invariant to be quickly restored.
 newEvVar fl pty
   | isGivenOrSolved fl    -- Create new variable and update the cache
-  = do { new <- forceNewEvVar fl pty
+  = do { 
+{- We lose a lot of time if we enable this check:
+         eref <- getTcSEvVarCache
+       ; ecache <- wrapTcS (TcM.readTcRef eref)
+       ; case lookupTM pty (evc_cache ecache) of
+           Just (_,cached_fl) 
+               | cached_fl `canSolve` fl 
+               -> pprTrace "Interesting: given newEvVar, missed caching opportunity!" empty $
+                  return ()
+           _ -> return ()
+-}
+         new <- forceNewEvVar fl pty
        ; return (EvVarCreated True new) }
 
   | otherwise             -- Otherwise lookup first
-  = do { eref <- getTcSEvVarCache
+  = {-# SCC "newEvVarWanted" #-}
+    do { eref <- getTcSEvVarCache
        ; ecache <- wrapTcS (TcM.readTcRef eref)
        ; case lookupTM pty (evc_cache ecache) of
            Just (cached_evvar, cached_flavor)
@@ -1322,9 +1397,10 @@ updateCache ecache (ev,fl,pty)
         ecache'    = alterTM pty (\_ -> Just (ev,fl)) $
                      evc_cache ecache
 
-delCachedEvVar :: EvVar -> TcS ()
-delCachedEvVar ev
-  = do { eref   <- getTcSEvVarCache
+delCachedEvVar :: EvVar -> CtFlavor -> TcS ()
+delCachedEvVar ev _fl
+  = {-# SCC "delCachedEvVarOther" #-}
+    do { eref   <- getTcSEvVarCache
        ; ecache <- wrapTcS (TcM.readTcRef eref)
        ; wrapTcS $ TcM.writeTcRef eref (delFromCache ecache ev) }
 
@@ -1361,13 +1437,13 @@ pprEvVarCache tm = ppr (foldTM mk_pair tm [])
  where mk_pair (co,_) cos = (co, liftedCoercionKind co) : cos
 
 
-newGivenEqVar :: CtFlavor -> TcType -> TcType -> Coercion -> TcS EvVar
+newGivenEqVar :: CtFlavor -> TcType -> TcType -> Coercion -> TcS (CtFlavor,EvVar)
 -- Pre: fl is Given
 newGivenEqVar fl ty1 ty2 co 
   = do { ecv <- newEqVar fl ty1 ty2
        ; let v = evc_the_evvar ecv -- Will be a new EvVar by post of newEvVar
-       ; setEvBind v (EvCoercionBox co)
-       ; return v }
+       ; fl' <- setEvBind v (EvCoercionBox co) fl
+       ; return (fl',v) }
 
 newEqVar :: CtFlavor -> TcType -> TcType -> TcS EvVarCreated
 newEqVar fl ty1 ty2 
@@ -1431,26 +1507,6 @@ getInertEqs :: TcS (TyVarEnv (Ct,Coercion), InScopeSet)
 getInertEqs = do { inert <- getTcSInerts
                  ; return (inert_eqs inert, inert_eq_tvs inert) }
 
-rewriteFromInertEqs :: (TyVarEnv (Ct,Coercion), InScopeSet)
-                    -- Precondition: Ct are CTyEqCans only!
-                    -> CtFlavor 
-                    -> EvVar 
-                    -> TcS (EvVar,Bool)
--- Boolean flag returned: True <-> no rewriting happened
-rewriteFromInertEqs (subst,inscope) fl v 
-  = do { let co = liftInertEqsTy (subst,inscope) fl (evVarPred v)
-       ; if isReflCo co then return (v,True)
-         else do { traceTcS "rewriteFromInertEqs" $
-                   text "Original item =" <+> ppr v <+> dcolon <+> ppr (evVarPred v)
-                 ; v' <- forceNewEvVar fl (pSnd (liftedCoercionKind co))
-                 ; case fl of 
-                     Wanted {}  -> setEvBind v (EvCast v' (mkSymCo co)) 
-                     Given {}   -> setEvBind v' (EvCast v co) 
-                     Derived {} -> return ()
-                 ; traceTcS "rewriteFromInertEqs" $
-                   text "Rewritten item =" <+> ppr v' <+> dcolon <+> ppr (evVarPred v')
-                 ; return (v',False) } }
-
 
 -- See Note [LiftInertEqs]
 liftInertEqsTy :: (TyVarEnv (Ct,Coercion),InScopeSet)
@@ -1506,7 +1562,7 @@ ty_cts_subst subst inscope fl ty
                 unused_evvar = panic "ty_cts_subst: This var is just an alpha-renaming!"
 \end{code}
 
-Note [LiftInertEqsPred]
+Note [LiftInertEqsTy]
 ~~~~~~~~~~~~~~~~~~~~~~~ 
 The function liftInertEqPred behaves almost like liftCoSubst (in
 Coercion), but accepts a map TyVarEnv (Ct,Coercion) instead of a
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 68082d4156..76e02e6629 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1046,7 +1046,11 @@ solveCTyFunEqs cts
       ; return (niFixTvSubst ni_subst, unsolved_can_cts) }
   where
     solve_one (cv,tv,ty) = do { setWantedTyBind tv ty
-                              ; setEqBind cv (mkReflCo ty) }
+                              ; _ <- setEqBind cv (mkReflCo ty) $
+                                       (Wanted $ panic "Met an already solved function equality!")
+                              ; return () -- Don't care about flavors etc this is
+                                          -- the last thing happening
+                              }
 
 ------------
 type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)])
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index aaed359a10..17179fd2f1 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -22,6 +22,7 @@ module Coercion (
         -- ** Functions over coercions
         coVarKind,
         coercionType, coercionKind, coercionKinds, isReflCo, liftedCoercionKind,
+        isReflCo_maybe,
         mkCoercionType,
 
 	-- ** Constructing coercions
diff --git a/compiler/utils/UniqFM.lhs b/compiler/utils/UniqFM.lhs
index c3d204215e..4ee6e190cc 100644
--- a/compiler/utils/UniqFM.lhs
+++ b/compiler/utils/UniqFM.lhs
@@ -20,7 +20,7 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
 of arguments of combining function.
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# OPTIONS -fno-warn-tabs -XGeneralizedNewtypeDeriving #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
 -- detab the module (please do the detabbing in a separate patch). See
@@ -74,6 +74,7 @@ import Compiler.Hoopl   hiding (Unique)
 import Data.Function (on)
 import qualified Data.IntMap as M
 import qualified Data.Foldable as Foldable
+import qualified Data.Traversable as Traversable
 import Data.Typeable
 import Data.Data
 \end{code}
@@ -179,11 +180,19 @@ ufmToList	:: UniqFM elt -> [(Unique, elt)]
 
 \begin{code}
 newtype UniqFM ele = UFM { unUFM :: M.IntMap ele }
-  deriving (Typeable,Data)
+  deriving (Typeable,Data, Traversable.Traversable, Functor)
 
 instance Eq ele => Eq (UniqFM ele) where
     (==) = (==) `on` unUFM
 
+{-
+instance Functor UniqFM where
+   fmap f = fmap f . unUFM
+
+instance Traversable.Traversable UniqFM where 
+    traverse f = Traversable.traverse f . unUFM
+-}
+
 instance Foldable.Foldable UniqFM where
     foldMap f = Foldable.foldMap f . unUFM
 
diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs
index 8465c203b0..d194135951 100644
--- a/compiler/vectorise/Vectorise/Builtins.hs
+++ b/compiler/vectorise/Vectorise/Builtins.hs
@@ -8,7 +8,6 @@ module Vectorise.Builtins (
   Builtins(..),
   
   -- * Wrapped selectors
-  parray_PrimTyCon,
   selTy, selsTy,
   selReplicate,
   selTags,
@@ -26,7 +25,7 @@ module Vectorise.Builtins (
   closureCtrFun,
 
   -- * Initialisation
-  initBuiltins, initBuiltinVars, initBuiltinTyCons
+  initBuiltins, initBuiltinVars,
 ) where
 
 import Vectorise.Builtins.Base
diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs
index 586c950f62..90afedfb87 100644
--- a/compiler/vectorise/Vectorise/Builtins/Base.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Base.hs
@@ -13,7 +13,6 @@ module Vectorise.Builtins.Base (
   Builtins(..),
   
   -- * Projections
-  parray_PrimTyCon,
   selTy, selsTy,
   selReplicate,
   selTags,
@@ -71,9 +70,7 @@ aLL_DPH_PRIM_TYCONS = map tyConName [intPrimTyCon, {- floatPrimTyCon, -} doubleP
 --
 data Builtins 
         = Builtins 
-        { parrayTyCon          :: TyCon                     -- ^ PArray
-        , parray_PrimTyCons    :: NameEnv TyCon             -- ^ PArray_Int# etc.
-        , pdataTyCon           :: TyCon                     -- ^ PData
+        { pdataTyCon           :: TyCon                     -- ^ PData
         , pdatasTyCon          :: TyCon                     -- ^ PDatas
         , prClass              :: Class                     -- ^ PR
         , prTyCon              :: TyCon                     -- ^ PR
@@ -119,9 +116,6 @@ data Builtins
 -- We use these wrappers instead of indexing the `Builtin` structure directly
 -- because they give nicer panic messages if the indexed thing cannot be found.
 
-parray_PrimTyCon :: TyCon -> Builtins -> TyCon
-parray_PrimTyCon tc bi = lookupEnvBuiltin "parray_PrimTyCon" (parray_PrimTyCons bi) (tyConName tc)
-
 selTy :: Int -> Builtins -> Type
 selTy           = indexBuiltin "selTy" selTys
 
diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
index e2fddefacd..1ef8183869 100644
--- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs
+++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs
@@ -2,7 +2,7 @@
 
 module Vectorise.Builtins.Initialise (
   -- * Initialisation
-  initBuiltins, initBuiltinVars, initBuiltinTyCons
+  initBuiltins, initBuiltinVars
 ) where
 
 import Vectorise.Builtins.Base
@@ -30,12 +30,7 @@ import Data.Array
 --
 initBuiltins :: DsM Builtins
 initBuiltins
- = do {   -- 'PArray': desugared array type
-      ; parrayTyCon <- externalTyCon (fsLit "PArray")
-      ; parray_tcs  <- mapM externalTyCon (suffixed "PArray" aLL_DPH_PRIM_TYCONS)
-      ; let parray_PrimTyCons = mkNameEnv (zip aLL_DPH_PRIM_TYCONS parray_tcs)
-
-          -- 'PData': type family mapping array element types to array representation types
+ = do {   -- 'PData': type family mapping array element types to array representation types
           -- Not all backends use `PDatas`.
       ; pdataTyCon  <- externalTyCon (fsLit "PData")
       ; pdatasTyCon <- externalTyCon (fsLit "PDatas")
@@ -80,7 +75,8 @@ initBuiltins
       ; scalar_map       <- externalVar (fsLit "scalar_map")
       ; scalar_zip2      <- externalVar (fsLit "scalar_zipWith")
       ; scalar_zips      <- mapM externalVar (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS)
-      ; let scalarZips   = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips)
+      ; let scalarZips   = listArray (1, mAX_DPH_SCALAR_ARGS) 
+                                     (scalar_map : scalar_zip2 : scalar_zips)
 
           -- Types and functions for generic type representations
       ; voidTyCon        <- externalTyCon (fsLit "Void")
@@ -119,9 +115,7 @@ initBuiltins
       ; liftingContext  <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) newUnique
 
       ; return $ Builtins 
-               { parrayTyCon          = parrayTyCon
-               , parray_PrimTyCons    = parray_PrimTyCons
-               , pdataTyCon           = pdataTyCon
+               { pdataTyCon           = pdataTyCon
                , pdatasTyCon          = pdatasTyCon
                , preprTyCon           = preprTyCon
                , prClass              = prClass
@@ -196,20 +190,6 @@ initBuiltinVars (Builtins { })
       where
         mk_tup n name = (tupleCon BoxedTuple n, name)
 
--- |Get a list of names to `TyCon`s in the mock prelude.
---
-initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
--- FIXME: * must be replaced by VECTORISE pragmas!!!
---        * then we can remove 'parrayTyCon' from the Builtins as well
-initBuiltinTyCons bi
-  = do
-      return $ (tyConName funTyCon, closureTyCon bi)
-             : (parrTyConName,      parrayTyCon bi)
-
-             -- FIXME: temporary
-             : (tyConName $ parrayTyCon bi, parrayTyCon bi)
-             : []
-
 
 -- Auxilliary look up functions -----------------------------------------------
 
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index ffaf388b31..166262f744 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -10,7 +10,6 @@ module Vectorise.Env (
   initGlobalEnv,
   extendImportedVarsEnv,
   extendFamEnv,
-  extendTyConsEnv,
   setPAFunsEnv,
   setPRFunsEnv,
   modVectInfo
@@ -182,12 +181,6 @@ extendFamEnv new genv
   = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) }
   where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv
 
--- |Extend the list of type constructors in an environment.
---
-extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
-extendTyConsEnv ps genv
-  = genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
-
 -- |Set the list of PA functions in an environment.
 --
 setPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index 0706e25f4f..a6bf6d973f 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -80,7 +80,6 @@ initV hsc_env guts info thing_inside
       = do {   -- set up tables of builtin entities
            ; builtins        <- initBuiltins
            ; builtin_vars    <- initBuiltinVars builtins
-           ; builtin_tycons  <- initBuiltinTyCons builtins
 
                -- set up class and type family envrionments
            ; eps <- liftIO $ hscEPS hsc_env
@@ -91,7 +90,6 @@ initV hsc_env guts info thing_inside
 
                -- construct the initial global environment
            ; let genv = extendImportedVarsEnv builtin_vars
-                        . extendTyConsEnv     builtin_tycons
                         . setPAFunsEnv        builtin_pas
                         . setPRFunsEnv        builtin_prs
                         $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs
index f393f01e92..bb8cc1affa 100644
--- a/compiler/vectorise/Vectorise/Monad/Global.hs
+++ b/compiler/vectorise/Vectorise/Monad/Global.hs
@@ -39,8 +39,11 @@ import TyCon
 import DataCon
 import NameEnv
 import NameSet
+import Name
 import VarEnv
 import VarSet
+import Var as Var
+import FastString
 import Outputable
 
 
@@ -70,8 +73,22 @@ defGlobalVar :: Var -> Var -> VM ()
 defGlobalVar v v'
   = do { traceVt "add global var mapping:" (ppr v <+> text "-->" <+> ppr v') 
 
-       ; updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }
+           -- check for duplicate vectorisation
+       ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v
+       ; case currentDef of
+           Just old_v' -> cantVectorise "Variable is already vectorised:" $
+                            ppr v <+> moduleOf v old_v'
+           Nothing     -> return ()
+
+       ; updGEnv  $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' }
        }
+  where
+    moduleOf var var' | var == var'
+                      = ptext (sLit "vectorises to itself")
+                      | Just mod <- nameModule_maybe (Var.varName var') 
+                      = ptext (sLit "in module") <+> ppr mod
+                      | otherwise
+                      = ptext (sLit "in the current module")
 
 
 -- Vectorisation declarations -------------------------------------------------
@@ -120,8 +137,26 @@ lookupTyCon tc
 -- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
 --
 defTyCon :: TyCon -> TyCon -> VM ()
-defTyCon tc tc' = updGEnv $ \env ->
-  env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
+defTyCon tc tc'
+  = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr tc') 
+
+           -- check for duplicate vectorisation
+       ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
+       ; case currentDef of
+           Just old_tc' -> cantVectorise "Type constructor or class is already vectorised:" $
+                            ppr tc <+> moduleOf tc old_tc'
+           Nothing     -> return ()
+
+       ; updGEnv $ \env -> 
+           env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
+       }
+  where
+    moduleOf tc tc' | tc == tc'
+                    = ptext (sLit "vectorises to itself")
+                    | Just mod <- nameModule_maybe (tyConName tc') 
+                    = ptext (sLit "in module") <+> ppr mod
+                    | otherwise
+                    = ptext (sLit "in the current module")
 
 -- |Get the set of all vectorised type constructors.
 --