Merge remote-tracking branch 'origin/master' into ghc-parmake-gsoc

41 files changed, 492 insertions, 284 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 14e29c1d99..21553ab4f9 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -695,8 +695,7 @@ dataConArgUnpack arg_ty
     -- An interface file specified Unpacked, but we couldn't unpack it
 
 isUnpackableType :: FamInstEnvs -> Type -> Bool
--- True if we can unpack the UNPACK fields of the constructor
--- without involving the NameSet tycons
+-- True if we can unpack the UNPACK the argument type 
 -- See Note [Recursive unboxing]
 -- We look "deeply" inside rather than relying on the DataCons
 -- we encounter on the way, because otherwise we might well
@@ -730,9 +729,11 @@ isUnpackableType fam_envs ty
          -- NB: dataConStrictMarks gives the *user* request; 
          -- We'd get a black hole if we used dataConRepBangs
 
-    attempt_unpack (HsUnpack {})              = True
-    attempt_unpack (HsUserBang (Just unpk) _) = unpk
-    attempt_unpack _                          = False
+    attempt_unpack (HsUnpack {})                 = True
+    attempt_unpack (HsUserBang (Just unpk) bang) = bang && unpk
+    attempt_unpack (HsUserBang Nothing bang)     = bang  -- Be conservative
+    attempt_unpack HsStrict                      = False
+    attempt_unpack HsNoBang                      = False
 \end{code}
 
 Note [Unpack one-wide fields]
@@ -761,14 +762,26 @@ Here we can represent T with an Int#.
 
 Note [Recursive unboxing]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
-Be careful not to try to unbox this!
-	data T = MkT {-# UNPACK #-} !T Int
-Reason: consider
+Consider
   data R = MkR {-# UNPACK #-} !S Int
   data S = MkS {-# UNPACK #-} !Int
 The representation arguments of MkR are the *representation* arguments
-of S (plus Int); the rep args of MkS are Int#.  This is obviously no
-good for T, because then we'd get an infinite number of arguments.
+of S (plus Int); the rep args of MkS are Int#.  This is all fine.
+
+But be careful not to try to unbox this!
+	data T = MkT {-# UNPACK #-} !T Int
+Because then we'd get an infinite number of arguments.
+
+Here is a more complicated case:
+	data S = MkS {-# UNPACK #-} !T Int
+	data T = MkT {-# UNPACK #-} !S Int
+Each of S and T must decide independendently whether to unpack
+and they had better not both say yes. So they must both say no.
+
+Also behave conservatively when there is no UNPACK pragma
+	data T = MkS !T Int
+with -funbox-strict-fields or -funbox-small-strict-fields
+we need to behave as if there was an UNPACK pragma there.
 
 But it's the *argument* type that matters. This is fine:
 	data S = MkS S !Int
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 47811bcd7f..7a4fb98a79 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -52,7 +52,7 @@ data CmmNode e x where
       [CmmActual] ->            -- zero or more arguments
       CmmNode O O
       -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
-      -- See Note [foreign calls clobber GlobalRegs]
+      -- See Note [Unsafe foreign calls clobber caller-save registers]
       --
       -- Invariant: the arguments and the ForeignTarget must not
       -- mention any registers for which CodeGen.Platform.callerSaves
@@ -158,8 +158,8 @@ made manifest in CmmLayoutStack, where they are lowered into the above
 sequence.
 -}
 
-{- Note [foreign calls clobber GlobalRegs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Unsafe foreign calls clobber caller-save registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 A foreign call is defined to clobber any GlobalRegs that are mapped to
 caller-saves machine registers (according to the prevailing C ABI).
@@ -329,8 +329,9 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where
   foldRegsDefd dflags f z n = case n of
     CmmAssign lhs _ -> fold f z lhs
     CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
-    CmmCall {} -> fold f z activeRegs
-    CmmForeignCall {tgt=tgt} -> fold f z (foreignTargetRegs tgt)
+    CmmCall        {} -> fold f z activeRegs
+    CmmForeignCall {} -> fold f z activeRegs
+                      -- See Note [Safe foreign calls clobber STG registers]
     _ -> z
     where fold :: forall a b.
                    DefinerOfRegs GlobalReg a =>
@@ -344,6 +345,74 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where
           foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
           foreignTargetRegs _ = activeCallerSavesRegs
 
+-- Note [Safe foreign calls clobber STG registers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- During stack layout phase every safe foreign call is expanded into a block
+-- that contains unsafe foreign call (instead of safe foreign call) and ends
+-- with a normal call (See Note [Foreign calls]). This means that we must
+-- treat safe foreign call as if it was a normal call (because eventually it
+-- will be). This is important if we try to run sinking pass before stack
+-- layout phase. Consider this example of what might go wrong (this is cmm
+-- code from stablename001 test). Here is code after common block elimination
+-- (before stack layout):
+--
+--  c1q6:
+--      _s1pf::P64 = R1;
+--      _c1q8::I64 = performMajorGC;
+--      I64[(young<c1q9> + 8)] = c1q9;
+--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)
+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- If we run sinking pass now (still before stack layout) we will get this:
+--
+--  c1q6:
+--      I64[(young<c1q9> + 8)] = c1q9;
+--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)
+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
+-- safe call to performMajorGC will be turned into:
+--
+--  c1q6:
+--      _s1pc::P64 = P64[Sp + 8];
+--      I64[Sp - 8] = c1q9;
+--      Sp = Sp - 8;
+--      I64[I64[CurrentTSO + 24] + 16] = Sp;
+--      P64[CurrentNursery + 8] = Hp + 8;
+--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]
+--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);
+--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();
+--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]
+--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);
+--      BaseReg = _u1qJ::I64;
+--      _u1qK::P64 = CurrentTSO;
+--      _u1qL::P64 = I64[_u1qK::P64 + 24];
+--      Sp = I64[_u1qL::P64 + 16];
+--      SpLim = _u1qL::P64 + 192;
+--      HpAlloc = 0;
+--      Hp = I64[CurrentNursery + 8] - 8;
+--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
+--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      _s1pf::P64 = R1;         <------ INCORRECT!
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
+-- call is clearly incorrect. This is what would happen if we assumed that
+-- safe foreign call has the same semantics as unsafe foreign call. To prevent
+-- this we need to treat safe foreign call as if was normal call.
 
 -----------------------------------
 -- mapping Expr in CmmNode
@@ -429,6 +498,8 @@ foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
 foldExpForeignTarget _   (PrimTarget _)      z = z
 
 -- Take a folder on expressions and apply it recursively.
+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
+-- itself, delegating all the other CmmExpr forms to 'f'.
 wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
 wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
 wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 9f8a3975e7..41323ecad3 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -43,38 +43,52 @@ import qualified Data.Set as Set
 --
 --  * Start by doing liveness analysis.
 --
---  * Keep a list of assignments A; earlier ones may refer to later ones
+--  * Keep a list of assignments A; earlier ones may refer to later ones.
+--    Currently we only sink assignments to local registers, because we don't
+--    have liveness information about global registers.
 --
 --  * Walk forwards through the graph, look at each node N:
---    * If any assignments in A (1) occur only once in N, and (2) are
---      not live after N, inline the assignment and remove it
---      from A.
---    * If N is an assignment:
---      * If the register is not live after N, discard it
---      * otherwise pick up the assignment and add it to A
---    * If N is a non-assignment node:
+--
+--    * If it is a dead assignment, i.e. assignment to a register that is
+--      not used after N, discard it.
+--
+--    * Try to inline based on current list of assignments
+--      * If any assignments in A (1) occur only once in N, and (2) are
+--        not live after N, inline the assignment and remove it
+--        from A.
+--
+--      * If an assignment in A is cheap (RHS is local register), then
+--        inline the assignment and keep it in A in case it is used afterwards.
+--
+--      * Otherwise don't inline.
+--
+--    * If N is assignment to a local register pick up the assignment
+--      and add it to A.
+--
+--    * If N is not an assignment to a local register:
 --      * remove any assignments from A that conflict with N, and
---        place them before N in the current block.  (we call this
---        "dropping" the assignments).
+--        place them before N in the current block.  We call this
+--        "dropping" the assignments.
+--
 --      * An assignment conflicts with N if it:
 --        - assigns to a register mentioned in N
 --        - mentions a register assigned by N
 --        - reads from memory written by N
 --      * do this recursively, dropping dependent assignments
---    * At a multi-way branch:
---      * drop any assignments that are live on more than one branch
---      * if any successor has more than one predecessor (a
---        join-point), drop everything live in that successor
--- 
--- As a side-effect we'll delete some dead assignments (transitively,
--- even).  This isn't as good as removeDeadAssignments, but it's much
--- cheaper.
-
--- If we do this *before* stack layout, we might be able to avoid
--- saving some things across calls/procpoints.
 --
--- *but*, that will invalidate the liveness analysis, and we'll have
--- to re-do it.
+--    * At an exit node:
+--      * drop any assignments that are live on more than one successor
+--        and are not trivial
+--      * if any successor has more than one predecessor (a join-point),
+--        drop everything live in that successor. Since we only propagate
+--        assignments that are not dead at the successor, we will therefore
+--        eliminate all assignments dead at this point. Thus analysis of a
+--        join-point will always begin with an empty list of assignments.
+--
+--
+-- As a result of above algorithm, sinking deletes some dead assignments
+-- (transitively, even).  This isn't as good as removeDeadAssignments,
+-- but it's much cheaper.
 
 -- -----------------------------------------------------------------------------
 -- things that we aren't optimising very well yet.
@@ -122,6 +136,12 @@ type Assignment = (LocalReg, CmmExpr, AbsMem)
   -- Assignment caches AbsMem, an abstraction of the memory read by
   -- the RHS of the assignment.
 
+type Assignments = [Assignment]
+  -- A sequence of assignements; kept in *reverse* order
+  -- So the list [ x=e1, y=e2 ] means the sequence of assignments
+  --     y = e2
+  --     x = e1
+
 cmmSink :: DynFlags -> CmmGraph -> CmmGraph
 cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
   where
@@ -132,7 +152,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
 
   join_pts = findJoinPoints blocks
 
-  sink :: BlockEnv [Assignment] -> [CmmBlock] -> [CmmBlock]
+  sink :: BlockEnv Assignments -> [CmmBlock] -> [CmmBlock]
   sink _ [] = []
   sink sunk (b:bs) =
     -- pprTrace "sink" (ppr lbl) $
@@ -209,7 +229,8 @@ isSmall _ = False
 
 isTrivial :: CmmExpr -> Bool
 isTrivial (CmmReg (CmmLocal _)) = True
--- isTrivial (CmmLit _) = True
+-- isTrivial (CmmLit _) = True  -- Disabled because it used to make thing worse.
+                                -- Needs further investigation
 isTrivial _ = False
 
 --
@@ -234,7 +255,7 @@ findJoinPoints blocks = mapFilter (>1) succ_counts
 -- filter the list of assignments to remove any assignments that
 -- are not live in a continuation.
 --
-filterAssignments :: DynFlags -> LocalRegSet -> [Assignment] -> [Assignment]
+filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments
 filterAssignments dflags live assigs = reverse (go assigs [])
   where go []             kept = kept
         go (a@(r,_,_):as) kept | needed    = go as (a:kept)
@@ -249,26 +270,36 @@ filterAssignments dflags live assigs = reverse (go assigs [])
 -- -----------------------------------------------------------------------------
 -- Walk through the nodes of a block, sinking and inlining assignments
 -- as we go.
+--
+-- On input we pass in a:
+--    * list of nodes in the block
+--    * a list of assignments that appeared *before* this block and
+--      that are being sunk.
+--
+-- On output we get:
+--    * a new block
+--    * a list of assignments that will be placed *after* that block.
+--
 
 walk :: DynFlags
      -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with
                                         -- the set of registers live *after*
                                         -- this node.
 
-     -> [Assignment]                    -- The current list of
+     -> Assignments                     -- The current list of
                                         -- assignments we are sinking.
                                         -- Later assignments may refer
                                         -- to earlier ones.
 
      -> ( Block CmmNode O O             -- The new block
-        , [Assignment]                  -- Assignments to sink further
+        , Assignments                   -- Assignments to sink further
         )
 
 walk dflags nodes assigs = go nodes emptyBlock assigs
  where
    go []               block as = (block, as)
    go ((live,node):ns) block as
-    | shouldDiscard node live    = go ns block as
+    | shouldDiscard node live           = go ns block as -- discard dead assignment
     | Just a <- shouldSink dflags node2 = go ns block (a : as1)
     | otherwise                         = go ns block' as'
     where
@@ -316,17 +347,17 @@ shouldDiscard node live
        CmmAssign r (CmmReg r') | r == r' -> True
        CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)
        _otherwise -> False
-  
+
 
 toNode :: Assignment -> CmmNode O O
 toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
 
-dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> [Assignment]
-                      -> ([CmmNode O O], [Assignment])
+dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments
+                      -> ([CmmNode O O], Assignments)
 dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()
 
-dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> [Assignment]
-                -> ([CmmNode O O], [Assignment])
+dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
+                -> ([CmmNode O O], Assignments)
 dropAssignments dflags should_drop state assigs
  = (dropped, reverse kept)
  where
@@ -351,16 +382,16 @@ tryToInline
                                 -- that is live after the node, unless
                                 -- it is small enough to duplicate.
    -> CmmNode O x               -- The node to inline into
-   -> [Assignment]              -- Assignments to inline
+   -> Assignments               -- Assignments to inline
    -> (
         CmmNode O x             -- New node
-      , [Assignment]            -- Remaining assignments
+      , Assignments             -- Remaining assignments
       )
 
 tryToInline dflags live node assigs = go usages node [] assigs
  where
-  usages :: UniqFM Int
-  usages = foldRegsUsed dflags addUsage emptyUFM node
+  usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used
+  usages = foldLocalRegsUsed dflags addUsage emptyUFM node
 
   go _usages node _skipped [] = (node, [])
 
@@ -371,10 +402,10 @@ tryToInline dflags live node assigs = go usages node [] assigs
    | otherwise               = dont_inline
    where
         inline_and_discard = go usages' inl_node skipped rest
-          where usages' = foldRegsUsed dflags addUsage usages rhs
+          where usages' = foldLocalRegsUsed dflags addUsage usages rhs
 
-        dont_inline        = keep node  -- don't inline the assignment, keep it
-        inline_and_keep    = keep inl_node -- inline the assignment, keep it
+        dont_inline        = keep node     -- don't inline the assignment, keep it
+        inline_and_keep    = keep inl_node --       inline the assignment, keep it
 
         keep node' = (final_node, a : rest')
           where (final_node, rest') = go usages' node' (l:skipped) rest
@@ -470,10 +501,10 @@ conflicts dflags (r, rhs, addr) node
   | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
 
   -- (4) assignments that read caller-saves GlobalRegs conflict with a
-  -- foreign call.  See Note [foreign calls clobber GlobalRegs].
+  -- foreign call.  See Note [Unsafe foreign calls clobber caller-save registers]
   | CmmUnsafeForeignCall{} <- node, anyCallerSavesRegs dflags rhs = True
 
-  -- (5) foreign calls clobber heap: see Note [foreign calls clobber heap]
+  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]
   | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True
 
   -- (6) native calls clobber any memory
@@ -532,7 +563,8 @@ data AbsMem
 --  that was written in the same basic block.  To take advantage of
 --  non-aliasing of heap memory we will have to be more clever.
 
--- Note [foreign calls clobber]
+-- Note [Foreign calls clobber heap]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
 -- It is tempting to say that foreign calls clobber only
 -- non-heap/stack memory, but unfortunately we break this invariant in
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index 9b1bce4b57..bf950c4158 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -11,7 +11,7 @@ module StgCmm ( codeGen ) where
 #define FAST_STRING_NOT_NEEDED
 #include "HsVersions.h"
 
-import StgCmmProf
+import StgCmmProf (initCostCentres, ldvEnter)
 import StgCmmMonad
 import StgCmmEnv
 import StgCmmBind
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index dccefd0fb0..4762c5a4e0 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -20,7 +20,8 @@ import StgCmmMonad
 import StgCmmEnv
 import StgCmmCon
 import StgCmmHeap
-import StgCmmProf
+import StgCmmProf (curCCS, ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
+                   initUpdFrameProf, costCentreFrom)
 import StgCmmTicky
 import StgCmmLayout
 import StgCmmUtils
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index 57d4759346..eb00bbf0c0 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -23,7 +23,7 @@ import StgCmmEnv
 import StgCmmHeap
 import StgCmmUtils
 import StgCmmClosure
-import StgCmmProf
+import StgCmmProf ( curCCS )
 
 import CmmExpr
 import CLabel
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 331e65819f..c7fddd49dc 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -17,7 +17,7 @@ import StgCmmMonad
 import StgCmmHeap
 import StgCmmEnv
 import StgCmmCon
-import StgCmmProf
+import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)
 import StgCmmLayout
 import StgCmmPrim
 import StgCmmHpc
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 0b782fffcc..a688074b9e 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -18,7 +18,7 @@ module StgCmmForeign (
 #include "HsVersions.h"
 
 import StgSyn
-import StgCmmProf
+import StgCmmProf (storeCurCCS, ccsType, curCCS)
 import StgCmmEnv
 import StgCmmMonad
 import StgCmmUtils
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 97233aa500..f4c58e95e1 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -28,7 +28,7 @@ import CLabel
 import StgCmmLayout
 import StgCmmUtils
 import StgCmmMonad
-import StgCmmProf
+import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr)
 import StgCmmTicky
 import StgCmmClosure
 import StgCmmEnv
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 6c6e49dafa..b52d4e57df 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -29,7 +29,7 @@ import StgCmmArgRep -- notably: ( slowCallPattern )
 import StgCmmTicky
 import StgCmmMonad
 import StgCmmUtils
-import StgCmmProf
+import StgCmmProf (curCCS)
 
 import MkGraph
 import SMRep
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index c11df7009c..bb58024a4e 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -21,7 +21,7 @@ import StgCmmMonad
 import StgCmmUtils
 import StgCmmTicky
 import StgCmmHeap
-import StgCmmProf
+import StgCmmProf ( costCentreFrom, curCCS )
 
 import DynFlags
 import Platform
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 68aaea5b5c..1913e3ab93 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -16,7 +16,7 @@ A ``lint'' pass to check for Core correctness
 
 {-# OPTIONS_GHC -fprof-auto #-}
 
-module CoreLint ( lintCoreBindings, lintUnfolding ) where
+module CoreLint ( lintCoreBindings, lintUnfolding, lintExpr ) where
 
 #include "HsVersions.h"
 
@@ -120,14 +120,15 @@ find an occurence of an Id, we fetch it from the in-scope set.
 
 
 \begin{code}
-lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
+lintCoreBindings :: [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
 --   Returns (warnings, errors)
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
-lintCoreBindings binds
+lintCoreBindings local_in_scope binds
   = initL $ 
-    addLoc TopLevelBindings $
-    addInScopeVars binders  $
+    addLoc TopLevelBindings        $
+    addInScopeVars local_in_scope  $
+    addInScopeVars binders         $
 	-- Put all the top-level binders in scope at the start
 	-- This is because transformation rules can bring something
 	-- into use 'unexpectedly'
@@ -178,6 +179,18 @@ lintUnfolding locn vars expr
     (_warns, errs) = initL (addLoc (ImportedUnfolding locn) $
                             addInScopeVars vars	           $
                             lintCoreExpr expr)
+
+lintExpr :: [Var]		-- Treat these as in scope
+	 -> CoreExpr
+	 -> Maybe MsgDoc	-- Nothing => OK
+
+lintExpr vars expr
+  | isEmptyBag errs = Nothing
+  | otherwise       = Just (pprMessageBag errs)
+  where
+    (_warns, errs) = initL (addLoc TopLevelBindings $
+                            addInScopeVars vars	    $
+                            lintCoreExpr expr)
 \end{code}
 
 %************************************************************************
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index d87fdfc197..1a21253f39 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -172,7 +172,7 @@ corePrepPgm dflags hsc_env binds data_tycons = do
                       floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
-    endPass dflags CorePrep binds_out []
+    endPass hsc_env CorePrep binds_out []
     return binds_out
 
 corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index dd7307d190..baa28bc0cc 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -714,7 +714,9 @@ data Unfolding
 
 ------------------------------------------------
 data UnfoldingSource
-  = InlineRhs          -- The current rhs of the function
+  = -- See also Note [Historical note: unfoldings for wrappers]
+   
+    InlineRhs          -- The current rhs of the function
     		       -- Replace uf_tmpl each time around
 
   | InlineStable       -- From an INLINE or INLINABLE pragma 
@@ -739,13 +741,6 @@ data UnfoldingSource
                        -- (see MkId.lhs, calls to mkCompulsoryUnfolding).
                        -- Inline absolutely always, however boring the context.
 
-  | InlineWrapper      -- This unfolding is the wrapper in a
-                       -- worker/wrapper split from the strictness
-                       -- analyser
-                       --
-                       -- cf some history in TcIface's Note [wrappers
-                       -- in interface files]
-
 
 
 -- | 'UnfoldingGuidance' says when unfolding should take place
@@ -775,6 +770,25 @@ data UnfoldingGuidance
   | UnfNever	    -- The RHS is big, so don't inline it
 \end{code}
 
+Note [Historical note: unfoldings for wrappers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to have a nice clever scheme in interface files for
+wrappers. A wrapper's unfolding can be reconstructed from its worker's
+id and its strictness. This decreased .hi file size (sometimes
+significantly, for modules like GHC.Classes with many high-arity w/w
+splits) and had a slight corresponding effect on compile times.
+
+However, when we added the second demand analysis, this scheme lead to
+some Core lint errors. The second analysis could change the strictness
+signatures, which sometimes resulted in a wrapper's regenerated
+unfolding applying the wrapper to too many arguments.
+
+Instead of repairing the clever .hi scheme, we abandoned it in favor
+of simplicity. The .hi sizes are usually insignificant (excluding the
++1M for base libraries), and compile time barely increases (~+1% for
+nofib). The nicer upshot is that the UnfoldingSource no longer mentions
+an Id, so, eg, substitutions need not traverse them.
+
 
 Note [DFun unfoldings]
 ~~~~~~~~~~~~~~~~~~~~~~
@@ -844,7 +858,6 @@ isStableSource :: UnfoldingSource -> Bool
 -- Keep the unfolding template
 isStableSource InlineCompulsory   = True
 isStableSource InlineStable       = True
-isStableSource InlineWrapper      = True
 isStableSource InlineRhs          = False
 
 -- | Retrieves the template of an unfolding: panics if none is known
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index bbf9e0eb40..896f3723d2 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -103,7 +103,7 @@ mkDFunUnfolding bndrs con ops
 
 mkWwInlineRule :: CoreExpr -> Arity -> Unfolding
 mkWwInlineRule expr arity
-  = mkCoreUnfolding InlineWrapper True
+  = mkCoreUnfolding InlineStable True
                    (simpleOptExpr expr) arity
                    (UnfWhen unSaturatedOk boringCxtNotOk)
 
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 64e7d63590..00f9a9346f 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -422,7 +422,6 @@ instance Outputable UnfoldingGuidance where
 
 instance Outputable UnfoldingSource where
   ppr InlineCompulsory  = ptext (sLit "Compulsory")
-  ppr InlineWrapper     = ptext (sLit "Wrapper")
   ppr InlineStable      = ptext (sLit "InlineStable")
   ppr InlineRhs         = ptext (sLit "<vanilla>")
 
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index b65304a118..20a8a57299 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -143,14 +143,14 @@ deSugar hsc_env
 
 #ifdef DEBUG
           -- Debug only as pre-simple-optimisation program may be really big
-        ; endPass dflags CoreDesugar final_pgm rules_for_imps
+        ; endPass hsc_env CoreDesugar final_pgm rules_for_imps
 #endif
         ; (ds_binds, ds_rules_for_imps, ds_vects)
             <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
                          -- The simpleOptPgm gets rid of type
                          -- bindings plus any stupid dead code
 
-        ; endPass dflags CoreDesugarOpt ds_binds ds_rules_for_imps
+        ; endPass hsc_env CoreDesugarOpt ds_binds ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
         ; deps <- mkDependencies tcg_env
@@ -226,22 +226,23 @@ deSugarExpr :: HscEnv
             -> IO (Messages, Maybe CoreExpr)
 -- Prints its own errors; returns Nothing if error occurred
 
-deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
-    let dflags = hsc_dflags hsc_env
-    showPass dflags "Desugar"
+deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
+  = do { let dflags = hsc_dflags hsc_env
+       ; showPass dflags "Desugar"
 
-    -- Do desugaring
-    (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
-                                   dsLExpr tc_expr
+         -- Do desugaring
+       ; (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $
+                                 dsLExpr tc_expr
 
-    case mb_core_expr of
-      Nothing   -> return (msgs, Nothing)
-      Just expr -> do
+       ; case mb_core_expr of {
+            Nothing   -> return (msgs, Nothing) ;
+            Just expr ->
 
-        -- Dump output
-        dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
+ 
+         -- Dump output
+    do { dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 
-        return (msgs, Just expr)
+       ; return (msgs, Just expr) } } }
 \end{code}
 
 %************************************************************************
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 8dc4188bb9..f6e68e2836 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -583,8 +583,6 @@ data IfaceUnfolding
                  Bool           -- OK to inline even if context is boring
                  IfaceExpr
 
-  | IfWrapper IfaceExpr         -- cf TcIface's Note [wrappers in interface files]
-
   | IfDFunUnfold [IfaceBndr] [IfaceExpr]
 
 instance Binary IfaceUnfolding where
@@ -598,15 +596,12 @@ instance Binary IfaceUnfolding where
         put_ bh b
         put_ bh c
         put_ bh d
-    put_ bh (IfWrapper e) = do
-        putByte bh 2
-        put_ bh e
     put_ bh (IfDFunUnfold as bs) = do
-        putByte bh 3
+        putByte bh 2
         put_ bh as
         put_ bh bs
     put_ bh (IfCompulsory e) = do
-        putByte bh 4
+        putByte bh 3
         put_ bh e
     get bh = do
         h <- getByte bh
@@ -619,9 +614,7 @@ instance Binary IfaceUnfolding where
                     c <- get bh
                     d <- get bh
                     return (IfInlineRule a b c d)
-            2 -> do e <- get bh
-                    return (IfWrapper e)
-            3 -> do as <- get bh
+            2 -> do as <- get bh
                     bs <- get bh
                     return (IfDFunUnfold as bs)
             _ -> do e <- get bh
@@ -1288,7 +1281,6 @@ instance Outputable IfaceUnfolding where
   ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule")
                                             <+> ppr (a,uok,bok),
                                         pprParendIfaceExpr e]
-  ppr (IfWrapper e) = ptext (sLit "Wrapper:") <+> parens (ppr e)
   ppr (IfDFunUnfold bs es) = hang (ptext (sLit "DFun:") <+> sep (map ppr bs) <> dot)
                                 2 (sep (map pprParendIfaceExpr es))
 
@@ -1446,7 +1438,6 @@ freeNamesIfUnfold :: IfaceUnfolding -> NameSet
 freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e
 freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfWrapper e)          = freeNamesIfExpr e
 freeNamesIfUnfold (IfDFunUnfold bs es)   = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index d3b56d1f7b..44f99d520e 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1762,7 +1762,6 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity
           -> case guidance of
                UnfWhen unsat_ok boring_ok -> IfInlineRule arity unsat_ok boring_ok if_rhs
                _other                     -> IfCoreUnfold True if_rhs
-        InlineWrapper -> IfWrapper if_rhs
         InlineCompulsory -> IfCompulsory if_rhs
         InlineRhs        -> IfCoreUnfold False if_rhs
         -- Yes, even if guidance is UnfNever, expose the unfolding
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index dffd69b9ed..2d2e867390 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -605,33 +605,36 @@ tcIfaceDataCons tycon_name tycon _ if_cons
                          ifConStricts = if_stricts})
      = bindIfaceTyVars univ_tvs $ \ univ_tyvars -> do
        bindIfaceTyVars ex_tvs    $ \ ex_tyvars -> do
-        { name  <- lookupIfaceTop occ
+        { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
+        ; name  <- lookupIfaceTop occ
 
         -- Read the context and argument types, but lazily for two reasons
         -- (a) to avoid looking tugging on a recursive use of 
         --     the type itself, which is knot-tied
         -- (b) to avoid faulting in the component types unless 
         --     they are really needed
-        ; ~(eq_spec, theta, arg_tys) <- forkM (mk_doc name) $
+        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc name) $
              do { eq_spec <- tcIfaceEqSpec spec
                 ; theta   <- tcIfaceCtxt ctxt
                 ; arg_tys <- mapM tcIfaceType args
-                ; return (eq_spec, theta, arg_tys) }
+                ; stricts <- mapM tc_strict if_stricts 
+                        -- The IfBang field can mention 
+                        -- the type itself; hence inside forkM
+                ; return (eq_spec, theta, arg_tys, stricts) }
         ; lbl_names <- mapM lookupIfaceTop field_lbls
 
-        ; stricts <- mapM tc_strict if_stricts
-
         -- Remember, tycon is the representation tycon
         ; let orig_res_ty = mkFamilyTyConApp tycon 
                                 (substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
 
-        ; buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
+        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
                        name is_infix
                        stricts lbl_names
                        univ_tyvars ex_tyvars 
                        eq_spec theta 
                        arg_tys orig_res_ty tycon
-        }
+        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr name)
+        ; return con } 
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
     tc_strict IfNoBang = return HsNoBang
@@ -1204,25 +1207,6 @@ do_one (IfaceRec pairs) thing_inside
 %*                                                                      *
 %************************************************************************
 
-Note [wrappers in interface files]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to have a nice clever scheme in interface files for
-wrappers. A wrapper's unfolding can be reconstructed from its worker's
-id and its strictness. This decreased .hi file size (sometimes
-significantly, for modules like GHC.Classes with many high-arity w/w
-splits) and had a slight corresponding effect on compile times.
-
-However, when we added the second demand analysis, this scheme lead to
-some Core lint errors. The second analysis could change the strictness
-signatures, which sometimes resulted in a wrapper's regenerated
-unfolding applying the wrapper to too many arguments.
-
-Instead of repairing the clever .hi scheme, we abandoned it in favor
-of simplicity. The .hi sizes are usually insignificant (excluding the
-+1M for base libraries), and compile time barely increases (~+1% for
-nofib). The nicer upshot is that unfolding sources no longer include
-an Id, so, eg, substitutions need not traverse them any longer.
-
 \begin{code}
 tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
 tcIdDetails _  IfVanillaId = return VanillaId
@@ -1300,16 +1284,6 @@ tcUnfolding name dfun_ty _ (IfDFunUnfold bs ops)
   where
     doc = text "Class ops for dfun" <+> ppr name
     (_, _, cls, _) = tcSplitDFunTy dfun_ty
-
-tcUnfolding name _ info (IfWrapper if_expr)
-  = do  { mb_expr <- tcPragExpr name if_expr
-        ; return $ case mb_expr of
-            Nothing -> NoUnfolding
-            Just expr -> mkWwInlineRule expr arity -- see Note [wrappers in interface files]
-        }
-  where
-     -- Arity should occur before unfolding!
-    arity = arityInfo info
 \end{code}
 
 For unfoldings we try to do the job lazily, so that we never type check
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index e884fe5bcf..ad1b7c503a 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -81,9 +81,8 @@ import CoreTidy         ( tidyExpr )
 import Type             ( Type )
 import PrelNames
 import {- Kind parts of -} Type         ( Kind )
-import CoreLint         ( lintUnfolding )
+import CoreMonad        ( lintInteractiveExpr )
 import DsMeta           ( templateHaskellNames )
-import VarSet
 import VarEnv           ( emptyTidyEnv )
 import Panic
 
@@ -1385,12 +1384,12 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
 
             -- Desugar it
             ds_expr <- ioMsgMaybe $
-                           deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
+                       deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr
+            liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
             handleWarnings
 
             -- Then code-gen, and link it
-            hsc_env <- getHscEnv
-            hval    <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
+            hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
             let hval_io = unsafeCoerce# hval :: IO [HValue]
 
             return $ Just (ids, hval_io, fix_env)
@@ -1618,37 +1617,28 @@ hscCompileCoreExpr hsc_env srcspan ds_expr
     = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler")
             -- Otherwise you get a seg-fault when you run it
 
-    | otherwise = do
-        let dflags = hsc_dflags hsc_env
-        let lint_on = gopt Opt_DoCoreLinting dflags
+    | otherwise
+    = do { let dflags = hsc_dflags hsc_env
 
-        {- Simplify it -}
-        simpl_expr <- simplifyExpr dflags ds_expr
+           {- Simplify it -}
+         ; simpl_expr <- simplifyExpr dflags ds_expr
 
-        {- Tidy it (temporary, until coreSat does cloning) -}
-        let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
+           {- Tidy it (temporary, until coreSat does cloning) -}
+         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
 
-        {- Prepare for codegen -}
-        prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
+           {- Prepare for codegen -}
+         ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
 
-        {- Lint if necessary -}
-        -- ToDo: improve SrcLoc
-        when lint_on $
-            let ictxt  = hsc_IC hsc_env
-                te     = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt))
-                tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te
-                vars   = typeEnvIds te
-            in case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of
-                   Just err -> pprPanic "hscCompileCoreExpr" err
-                   Nothing  -> return ()
+           {- Lint if necessary -}
+         ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr 
 
-        {- Convert to BCOs -}
-        bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr
+           {- Convert to BCOs -}
+         ; bcos <- coreExprToBCOs dflags iNTERACTIVE prepd_expr
 
-        {- link it -}
-        hval <- linkExpr hsc_env srcspan bcos
+           {- link it -}
+         ; hval <- linkExpr hsc_env srcspan bcos
 
-        return hval
+         ; return hval }
 #endif
 
 
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 214e7f3315..d6a3da13e6 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -363,7 +363,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
               }
 
-        ; endPass dflags CoreTidy all_tidy_binds tidy_rules
+        ; endPass hsc_env CoreTidy all_tidy_binds tidy_rules
 
           -- If the endPass didn't print the rules, but ddump-rules is
           -- on, print now
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index e275b23778..094c2f55e6 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -794,6 +794,14 @@ primop  ThawArrayOp "thawArray#" GenPrimOp
   has_side_effects = True
   code_size = { primOpCodeSizeForeignCall + 4 }
 
+primop CasArrayOp  "casArray#" GenPrimOp
+   MutableArray# s a -> Int# -> a -> a -> State# s -> (# State# s, Int#, a #)
+   {Unsafe, machine-level atomic compare and swap on an element within an Array.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
+
 ------------------------------------------------------------------------
 section "Byte Arrays"
 	{Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of
@@ -1110,6 +1118,21 @@ primop  SetByteArrayOp "setByteArray#" GenPrimOp
   code_size = { primOpCodeSizeForeignCall + 4 }
   can_fail = True
 
+primop CasByteArrayOp_Int "casIntArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #)
+   {Machine-level atomic compare and swap on a word within a ByteArray.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
+primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp
+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #) 
+   {Machine-level word-sized fetch-and-add within a ByteArray.}
+   with
+   out_of_line = True
+   has_side_effects = True
+
+
 ------------------------------------------------------------------------
 section "Arrays of arrays"
 	{Operations on {\tt ArrayArray\#}. An {\tt ArrayArray\#} contains references to {\em unpointed}
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 0ef169085b..23501e3e1a 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -189,8 +189,10 @@ rnExpr (HsSpliceE splice)
 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
 #else
 rnExpr (HsQuasiQuoteE qq)
-  = runQuasiQuoteExpr qq        `thenM` \ (L _ expr') ->
-    rnExpr expr'
+  = runQuasiQuoteExpr qq        `thenM` \ lexpr' ->
+    -- Wrap the result of the quasi-quoter in parens so that we don't
+    -- lose the outermost location set by runQuasiQuote (#7918) 
+    rnExpr (HsPar lexpr')
 #endif  /* GHCI */
 
 ---------------------------------------------
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 90a83d6a8e..e7cecf8f3f 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -416,8 +416,9 @@ rnPatAndThen _ p@(QuasiQuotePat {})
 #else
 rnPatAndThen mk (QuasiQuotePat qq)
   = do { pat <- liftCps $ runQuasiQuotePat qq
-       ; L _ pat' <- rnLPatAndThen mk pat
-       ; return pat' }
+         -- Wrap the result of the quasi-quoter in parens so that we don't
+         -- lose the outermost location set by runQuasiQuote (#7918) 
+       ; rnPatAndThen mk (ParPat pat) }
 #endif  /* GHCI */
 
 rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index a1c4bac25c..c13ea336e4 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -269,7 +269,9 @@ rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without G
 rnHsTyKi isType doc (HsQuasiQuoteTy qq)
   = ASSERT( isType )
     do { ty <- runQuasiQuoteType qq
-       ; rnHsType doc (unLoc ty) }
+         -- Wrap the result of the quasi-quoter in parens so that we don't
+         -- lose the outermost location set by runQuasiQuote (#7918) 
+       ; rnHsType doc (HsParTy ty) }
 #endif
 
 rnHsTyKi isType _ (HsCoreTy ty)
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 31547e14a2..0af8201170 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -50,7 +50,8 @@ module CoreMonad (
     getAnnotations, getFirstAnnotations,
     
     -- ** Debug output
-    showPass, endPass, dumpPassResult, lintPassResult, dumpIfSet,
+    showPass, endPass, dumpPassResult, lintPassResult, 
+    lintInteractiveExpr, dumpIfSet,
 
     -- ** Screen output
     putMsg, putMsgS, errorMsg, errorMsgS, 
@@ -70,7 +71,7 @@ import Name( Name )
 import CoreSyn
 import PprCore
 import CoreUtils
-import CoreLint		( lintCoreBindings )
+import CoreLint		( lintCoreBindings, lintExpr )
 import HscTypes
 import Module
 import DynFlags
@@ -78,12 +79,13 @@ import StaticFlags
 import Rules            ( RuleBase )
 import BasicTypes       ( CompilerPhase(..) )
 import Annotations
-import Id		( Id )
 
 import IOEnv hiding     ( liftIO, failM, failWithM )
 import qualified IOEnv  ( liftIO )
 import TcEnv            ( tcLookupGlobal )
 import TcRnMonad        ( initTcForLookup )
+import Var
+import VarSet
 
 import Outputable
 import FastString
@@ -136,11 +138,12 @@ stuff before and after core passes, and do Core Lint when necessary.
 showPass :: DynFlags -> CoreToDo -> IO ()
 showPass dflags pass = Err.showPass dflags (showPpr dflags pass)
 
-endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
-endPass dflags pass binds rules
+endPass :: HscEnv -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
+endPass hsc_env pass binds rules
   = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules
-       ; lintPassResult dflags pass binds }      
+       ; lintPassResult hsc_env pass binds }      
   where
+    dflags = hsc_dflags hsc_env 
     mb_flag = case coreDumpFlag pass of
                 Just flag | dopt flag dflags                    -> Just flag
                           | dopt Opt_D_verbose_core2core dflags -> Just flag
@@ -178,12 +181,16 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules
                     , ptext (sLit "------ Local rules for imported ids --------")
                     , pprRules rules ]
 
-lintPassResult :: DynFlags -> CoreToDo -> CoreProgram -> IO ()
-lintPassResult dflags pass binds
-  = when (gopt Opt_DoCoreLinting dflags) $
-    do { let (warns, errs) = lintCoreBindings binds
+lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
+lintPassResult hsc_env pass binds
+  | not (gopt Opt_DoCoreLinting dflags)
+  = return ()
+  | otherwise
+  = do { let (warns, errs) = lintCoreBindings (interactiveInScope hsc_env) binds
        ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
        ; displayLintResults dflags pass warns errs binds  }
+  where 
+    dflags = hsc_dflags hsc_env
 
 displayLintResults :: DynFlags -> CoreToDo
                    -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
@@ -191,7 +198,7 @@ displayLintResults :: DynFlags -> CoreToDo
 displayLintResults dflags pass warns errs binds
   | not (isEmptyBag errs)
   = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
-           (vcat [ banner "errors", Err.pprMessageBag errs
+           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
                  , ptext (sLit "*** Offending Program ***")
                  , pprCoreBindings binds
                  , ptext (sLit "*** End of Offense ***") ])
@@ -206,19 +213,66 @@ displayLintResults dflags pass warns errs binds
   , not opt_NoDebugOutput
   , showLintWarnings pass
   = log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
-        (banner "warnings" $$ Err.pprMessageBag warns)
+        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
 
   | otherwise = return ()
   where
-    banner string = ptext (sLit "*** Core Lint")      <+> text string 
-                    <+> ptext (sLit ": in result of") <+> ppr pass
-                    <+> ptext (sLit "***")
+
+lint_banner :: String -> SDoc -> SDoc
+lint_banner string pass = ptext (sLit "*** Core Lint")      <+> text string 
+                          <+> ptext (sLit ": in result of") <+> pass
+                          <+> ptext (sLit "***")
 
 showLintWarnings :: CoreToDo -> Bool
 -- Disable Lint warnings on the first simplifier pass, because
 -- there may be some INLINE knots still tied, which is tiresomely noisy
 showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
 showLintWarnings _ = True
+
+lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
+lintInteractiveExpr what hsc_env expr
+  | not (gopt Opt_DoCoreLinting dflags)
+  = return ()
+  | Just err <- lintExpr (interactiveInScope hsc_env) expr 
+  = do { display_lint_err err
+       ; Err.ghcExit dflags 1 }
+  | otherwise
+  = return ()
+  where
+    dflags = hsc_dflags hsc_env
+
+    display_lint_err err
+      = do { log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
+               (vcat [ lint_banner "errors" (text what) 
+                     , err
+                     , ptext (sLit "*** Offending Program ***")
+                     , pprCoreExpr expr
+                     , ptext (sLit "*** End of Offense ***") ])
+           ; Err.ghcExit dflags 1 }
+
+interactiveInScope :: HscEnv -> [Var]
+-- In GHCi we may lint expressions, or bindings arising from 'deriving'
+-- clauses, that mention variables bound in the interactive context.
+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in TcRnDriver).
+-- So we have to tell Lint about them, lest it reports them as out of scope.
+-- 
+-- We do this by find local-named things that may appear free in interactive
+-- context.  This function is pretty revolting and quite possibly not quite right.
+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
+-- so this is a (cheap) no-op.
+-- 
+-- See Trac #8215 for an example
+interactiveInScope hsc_env 
+  = tyvars ++ vars
+  where
+    ictxt  = hsc_IC hsc_env
+    te     = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt))
+    vars   = typeEnvIds te
+    tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te
+              -- Why the type variables?  How can the top level envt have free tyvars?
+              -- I think it's becuase of the GHCi debugger, which can bind variables
+              --   f :: [t] -> [t]
+              -- where t is a RuntimeUnk (see TcType)
 \end{code}
 
 
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 75d5364f63..d17b0561f5 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -878,14 +878,13 @@ reOrderNodes depth bndr_set weak_fvs (node : nodes) binds
         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
                               -- Note [DFuns should not be loop breakers]
 
-        | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)
-        = case inl_source of
-             InlineWrapper    -> 10  -- Note [INLINE pragmas]
-             _other           ->  3  -- Data structures are more important than this
-                                     -- so that dictionary/method recursion unravels
-                -- Note that this case hits all InlineRule things, so we
-                -- never look at 'rhs' for InlineRule stuff. That's right, because
-                -- 'rhs' is irrelevant for inlining things with an InlineRule
+        | Just _ <- isStableCoreUnfolding_maybe (idUnfolding bndr)
+        = 3    -- Note [INLINE pragmas]
+               -- Data structures are more important than INLINE pragmas
+               -- so that dictionary/method recursion unravels
+               -- Note that this case hits all InlineRule things, so we
+               -- never look at 'rhs' for InlineRule stuff. That's right, because
+               -- 'rhs' is irrelevant for inlining things with an InlineRule
 
         | is_con_app rhs = 5  -- Data types help with cases: Note [Constructor applications]
 
@@ -968,32 +967,37 @@ Avoid choosing a function with an INLINE pramga as the loop breaker!
 If such a function is mutually-recursive with a non-INLINE thing,
 then the latter should be the loop-breaker.
 
-Usually this is just a question of optimisation. But a particularly
-bad case is wrappers generated by the demand analyser: if you make
-then into a loop breaker you may get an infinite inlining loop.  For
-example:
-  rec {
-        $wfoo x = ....foo x....
+   ----> Historical note, dating from when strictness wrappers
+   were generated from the strictness signatures:
 
-        {-loop brk-} foo x = ...$wfoo x...
-  }
-The interface file sees the unfolding for $wfoo, and sees that foo is
-strict (and hence it gets an auto-generated wrapper).  Result: an
-infinite inlining in the importing scope.  So be a bit careful if you
-change this.  A good example is Tree.repTree in
-nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
-breaker then compiling Game.hs goes into an infinite loop.  This
-happened when we gave is_con_app a lower score than inline candidates:
-
-  Tree.repTree
-    = __inline_me (/\a. \w w1 w2 ->
-                   case Tree.$wrepTree @ a w w1 w2 of
-                    { (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
-  Tree.$wrepTree
-    = /\a w w1 w2 ->
-      (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
-
-Here we do *not* want to choose 'repTree' as the loop breaker.
+      Usually this is just a question of optimisation. But a particularly
+      bad case is wrappers generated by the demand analyser: if you make
+      then into a loop breaker you may get an infinite inlining loop.  For
+      example:
+        rec {
+              $wfoo x = ....foo x....
+
+              {-loop brk-} foo x = ...$wfoo x...
+        }
+      The interface file sees the unfolding for $wfoo, and sees that foo is
+      strict (and hence it gets an auto-generated wrapper).  Result: an
+      infinite inlining in the importing scope.  So be a bit careful if you
+      change this.  A good example is Tree.repTree in
+      nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
+      breaker then compiling Game.hs goes into an infinite loop.  This
+      happened when we gave is_con_app a lower score than inline candidates:
+
+        Tree.repTree
+          = __inline_me (/\a. \w w1 w2 ->
+                         case Tree.$wrepTree @ a w w1 w2 of
+                          { (# ww1, ww2 #) -> Branch @ a ww1 ww2 })
+        Tree.$wrepTree
+          = /\a w w1 w2 ->
+            (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #)
+
+      Here we do *not* want to choose 'repTree' as the loop breaker.
+
+   -----> End of historical note
 
 Note [DFuns should not be loop breakers]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index a3101f715e..4b07d3bb1c 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -370,10 +370,11 @@ runCorePasses passes guts
     do_pass guts CoreDoNothing = return guts
     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
     do_pass guts pass
-       = do { dflags <- getDynFlags
+       = do { hsc_env <- getHscEnv
+            ; let dflags = hsc_dflags hsc_env
             ; liftIO $ showPass dflags pass
             ; guts' <- doCorePass dflags pass guts
-            ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
+            ; liftIO $ endPass hsc_env pass (mg_binds guts') (mg_rules guts')
             ; return guts' }
 
 doCorePass :: DynFlags -> CoreToDo -> ModGuts -> CoreM ModGuts
@@ -676,7 +677,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
 
                 -- Dump the result of this iteration
-           end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
+           dump_end_iteration dflags iteration_no counts1 binds2 rules1 ;
+           lintPassResult hsc_env pass binds2 ;
 
                 -- Loop
            do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
@@ -693,11 +695,10 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
 simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
 
 -------------------
-end_iteration :: DynFlags -> CoreToDo -> Int
+dump_end_iteration :: DynFlags -> Int
              -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
-end_iteration dflags pass iteration_no counts binds rules
-  = do { dumpPassResult dflags mb_flag hdr pp_counts binds rules
-       ; lintPassResult dflags pass binds }
+dump_end_iteration dflags iteration_no counts binds rules
+  = dumpPassResult dflags mb_flag hdr pp_counts binds rules
   where
     mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases
             | otherwise                               = Nothing
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index bf73bec240..a175e5ed4b 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -10,7 +10,7 @@ module Specialise ( specProgram ) where
 
 import Id
 import TcType hiding( substTy, extendTvSubstList )
-import Type( TyVar, isDictTy, mkPiTypes, classifyPredType, PredTree(..), isIPClass )
+import Type   hiding( substTy, extendTvSubstList )
 import Coercion( Coercion )
 import CoreMonad
 import qualified CoreSubst
@@ -1614,10 +1614,10 @@ mkCallUDs env f args
     _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts
                       , ppr (map (interestingDict env) dicts)]
     (tyvars, theta, _) = tcSplitSigmaTy (idType f)
-    constrained_tyvars = tyVarsOfTypes theta
+    constrained_tyvars = closeOverKinds (tyVarsOfTypes theta)
     n_tyvars           = length tyvars
     n_dicts            = length theta
-
+   
     spec_tys = [mk_spec_ty tv ty | (tv, Type ty) <- tyvars `zip` args]
     dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
 
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index b8bef9e0b2..2a33955148 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -559,9 +559,8 @@ mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
               -- In the inference case (no signature) this stuff figures out
               -- the right type variables and theta to quantify over
               -- See Note [Impedence matching]
-              my_tvs1 = growThetaTyVars theta (tyVarsOfType mono_ty)
-              my_tvs2 = foldVarSet (\tv tvs -> tyVarsOfType (tyVarKind tv) `unionVarSet` tvs) 
-                                   my_tvs1 my_tvs1            -- Add kind variables!  Trac #7916
+              my_tvs2 = closeOverKinds (growThetaTyVars theta (tyVarsOfType mono_ty))
+                            -- Include kind variables!  Trac #7916
               my_tvs   = filter (`elemVarSet` my_tvs2) qtvs   -- Maintain original order
               my_theta = filter (quantifyPred my_tvs2) theta
               inferred_poly_ty = mkSigmaTy my_tvs my_theta mono_ty
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 1481b2552d..9f89afe0af 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -409,7 +409,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        -- Remove any handwritten instance of poly-kinded Typeable and warn
        ; dflags <- getDynFlags
        ; when (wopt Opt_WarnTypeableInstances dflags) $
-              mapM_ (addWarnTc . instMsg) typeable_instances
+              mapM_ (failWithTc . instMsg) typeable_instances
 
        -- Check that if the module is compiled with -XSafe, there are no
        -- hand written instances of old Typeable as then unsafe casts could be
@@ -444,7 +444,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
     typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe"
                               ++ " Haskell! Can only derive them"
 
-    instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; ignoring "
+    instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace "
                                  ++ "the following instance:"))
                      2 (pprInstance (iSpec i))
 
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 481cb89ab0..6049d5be9f 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -511,11 +511,9 @@ quantifyTyVars :: TcTyVarSet -> TcTyVarSet -> TcM [TcTyVar]
 quantifyTyVars gbl_tvs tkvs
   = do { tkvs    <- zonkTyVarsAndFV tkvs
        ; gbl_tvs <- zonkTyVarsAndFV gbl_tvs
-       ; let (kvs1, tvs) = partitionVarSet isKindVar (tkvs `minusVarSet` gbl_tvs)
-             kvs2 = varSetElems (foldVarSet add_kvs kvs1 tvs
-                                 `minusVarSet` gbl_tvs )
-             add_kvs tv kvs = tyVarsOfType (tyVarKind tv) `unionVarSet` kvs 
+       ; let (kvs, tvs) = partitionVarSet isKindVar (closeOverKinds tkvs `minusVarSet` gbl_tvs)
                               -- NB kinds of tvs are zonked by zonkTyVarsAndFV
+             kvs2 = varSetElems kvs
              qtvs = varSetElems tvs                       
 
              -- In the non-PolyKinds case, default the kind variables
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 0b2e484f7a..5674b47ee2 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1639,6 +1639,7 @@ matchOpenFam :: TyCon -> [Type] -> TcS (Maybe FamInstMatch)
 matchOpenFam tycon args = wrapTcS $ tcLookupFamInst tycon args
 
 matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
+-- Given (F tys) return (ty, co), where co :: F tys ~ ty
 matchFam tycon args
   | isOpenSynFamilyTyCon tycon
   = do { maybe_match <- matchOpenFam tycon args
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 70e72f593f..f4e4dabd1b 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1524,14 +1524,16 @@ checkValidRoles tc
   = return ()
   where
     check_dc_roles datacon
-      = let univ_tvs   = dataConUnivTyVars datacon
-            ex_tvs     = dataConExTyVars datacon
-            args       = dataConRepArgTys datacon
-            univ_roles = zipVarEnv univ_tvs (tyConRoles tc)
+      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))
+           ; mapM_ (check_ty_roles role_env Representational) $
+                    eqSpecPreds eq_spec ++ theta ++ arg_tys }
+                    -- See Note [Role-checking data constructor arguments] in TcTyDecls
+      where
+        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon
+        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)
               -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs
-            ex_roles   = mkVarEnv (zip ex_tvs (repeat Nominal))
-            role_env   = univ_roles `plusVarEnv` ex_roles in
-        mapM_ (check_ty_roles role_env Representational) args
+        ex_roles   = mkVarEnv (zip ex_tvs (repeat Nominal))
+        role_env   = univ_roles `plusVarEnv` ex_roles
 
     check_ty_roles env role (TyVarTy tv)
       = case lookupVarEnv env tv of
diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs
index bea2cd19be..5091cab802 100644
--- a/compiler/typecheck/TcTyDecls.lhs
+++ b/compiler/typecheck/TcTyDecls.lhs
@@ -615,6 +615,19 @@ roles(~#) = N, N
 With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,
 called from checkValidTycon.
 
+Note [Role-checking data constructor arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T a where
+    MkT :: Eq b => F a -> (a->a) -> T (G a)
+
+Then we want to check the roles at which 'a' is used
+in MkT's type.  We want to work on the user-written type,
+so we need to take into account
+  * the arguments:   (F a) and (a->a)
+  * the context:     C a b
+  * the result type: (G a)   -- this is in the eq_spec
+
 \begin{code}
 type RoleEnv    = NameEnv [Role]        -- from tycon names to roles
 type RoleAnnots = NameEnv [Maybe Role]  -- from tycon names to role annotations,
@@ -695,9 +708,12 @@ irClass tc_name cls
 -- See Note [Role inference]
 irDataCon :: Name -> DataCon -> RoleM ()
 irDataCon tc_name datacon
-  = addRoleInferenceInfo tc_name (dataConUnivTyVars datacon) $
-    let ex_var_set = mkVarSet $ dataConExTyVars datacon in
-    mapM_ (irType ex_var_set) (dataConRepArgTys datacon)
+  = addRoleInferenceInfo tc_name univ_tvs $
+    mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ arg_tys)
+      -- See Note [Role-checking data constructor arguments] 
+  where
+    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig datacon
+    ex_var_set = mkVarSet ex_tvs
 
 irType :: VarSet -> Type -> RoleM ()
 irType = go
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 8a8de41159..af67808044 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -142,7 +142,7 @@ module TcType (
   isUnboxedTupleType,	-- Ditto
   isPrimitiveType, 
 
-  tyVarsOfType, tyVarsOfTypes,
+  tyVarsOfType, tyVarsOfTypes, closeOverKinds,
   tcTyVarsOfType, tcTyVarsOfTypes,
 
   pprKind, pprParendKind, pprSigmaType,
diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index 968d8695cc..1d68ede3b7 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -70,21 +70,23 @@ checkAmbiguity ctxt ty
   | otherwise
   = do { allow_ambiguous <- xoptM Opt_AllowAmbiguousTypes
        ; unless allow_ambiguous $ 
-    do {(subst, _tvs) <- tcInstSkolTyVars (varSetElems (tyVarsOfType ty))
+    do { traceTc "Ambiguity check for" (ppr ty)
+       ; (subst, _tvs) <- tcInstSkolTyVars (varSetElems (tyVarsOfType ty))
        ; let ty' = substTy subst ty  
               -- The type might have free TyVars,
               -- so we skolemise them as TcTyVars
               -- Tiresome; but the type inference engine expects TcTyVars
-       ; (_wrap, wanted) <- addErrCtxtM (mk_msg ty') $
-                            captureConstraints $
-                            tcSubType (AmbigOrigin ctxt) ctxt ty' ty'
 
          -- Solve the constraints eagerly because an ambiguous type
-         -- can cause a cascade of further errors.  The free tyvars
-         -- are skolemised, so we can safely use tcSimplifyTop
-       ; _ev_binds <- simplifyTop wanted
-
-       ; return () } } 
+         -- can cause a cascade of further errors.  Since the free 
+         -- tyvars are skolemised, we can safely use tcSimplifyTop
+       ; addErrCtxtM (mk_msg ty') $
+         do { (_wrap, wanted) <- captureConstraints $
+                                 tcSubType (AmbigOrigin ctxt) ctxt ty' ty'
+            ; _ev_binds <- simplifyTop wanted
+            ; return () }
+
+       ; traceTc "Done ambiguity check for" (ppr ty) } }
  where
    mk_msg ty tidy_env 
      = return (tidy_env', msg)
@@ -174,7 +176,8 @@ checkValidType ctxt ty
         -- Check that the thing has kind Type, and is lifted if necessary
         -- Do this second, because we can't usefully take the kind of an 
         -- ill-formed type such as (a~Int)
-       ; check_kind ctxt ty }
+       ; check_kind ctxt ty
+       ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) }
 
 checkValidMonoType :: Type -> TcM ()
 checkValidMonoType ty = check_mono_type SigmaCtxt MustBeMonoType ty
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 6cda16b9ec..b0da3edd53 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -802,7 +802,7 @@ isReflCo_maybe _                 = Nothing
 mkCoVarCo :: CoVar -> Coercion
 -- cv :: s ~# t
 mkCoVarCo cv
-  | ty1 `eqType` ty2 = Refl Nominal ty1
+  | ty1 `eqType` ty2 = Refl (coVarRole cv) ty1
   | otherwise        = CoVarCo cv
   where
     (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv
@@ -1360,8 +1360,7 @@ subst_co subst co
 
 substCoVar :: CvSubst -> CoVar -> Coercion
 substCoVar (CvSubst in_scope _ cenv) cv
-  | Just co  <- lookupVarEnv cenv cv      = ASSERT2( coercionRole co == Nominal, ppr co )
-                                            co
+  | Just co  <- lookupVarEnv cenv cv      = co
   | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1
   | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope)
                 ASSERT( isCoVar cv ) CoVarCo cv
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 8596dde439..5753aba0c1 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -85,7 +85,7 @@ module Type (
         constraintKindTyCon, anyKindTyCon,
 
         -- * Type free variables
-        tyVarsOfType, tyVarsOfTypes,
+        tyVarsOfType, tyVarsOfTypes, closeOverKinds,
         expandTypeSynonyms,
         typeSize, varSetElemsKvsFirst,
 
@@ -171,7 +171,6 @@ import Util
 import Outputable
 import FastString
 
-import Data.List        ( partition )
 import Maybes           ( orElse )
 import Data.Maybe       ( isJust )
 import Control.Monad    ( guard )
@@ -995,13 +994,6 @@ typeSize (AppTy t1 t2)   = typeSize t1 + typeSize t2
 typeSize (FunTy t1 t2)   = typeSize t1 + typeSize t2
 typeSize (ForAllTy _ t)  = 1 + typeSize t
 typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts)
-
-varSetElemsKvsFirst :: VarSet -> [TyVar]
--- {k1,a,k2,b} --> [k1,k2,a,b]
-varSetElemsKvsFirst set
-  = kvs ++ tvs
-  where
-    (kvs, tvs) = partition isKindVar (varSetElems set)
 \end{code}
 
 
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index cb5b8f0f18..2b127369d4 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -45,7 +45,7 @@ module TypeRep (
         pprPrefixApp, pprArrowChain, ppr_type,
 
         -- Free variables
-        tyVarsOfType, tyVarsOfTypes,
+        tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst,
 
         -- * Tidying type related things up for printing
         tidyType,      tidyTypes,
@@ -85,7 +85,7 @@ import StaticFlags( opt_PprStyle_Debug )
 import Util
 
 -- libraries
-import Data.List( mapAccumL )
+import Data.List( mapAccumL, partition )
 import qualified Data.Data        as Data hiding ( TyCon )
 \end{code}
 
@@ -327,6 +327,20 @@ tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar
 
 tyVarsOfTypes :: [Type] -> TyVarSet
 tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys
+
+closeOverKinds :: TyVarSet -> TyVarSet
+-- Add the kind variables free in the kinds
+-- of the tyvars in the given set
+closeOverKinds tvs
+  = foldVarSet (\tv ktvs -> tyVarsOfType (tyVarKind tv) `unionVarSet` ktvs) 
+               tvs tvs
+
+varSetElemsKvsFirst :: VarSet -> [TyVar]
+-- {k1,a,k2,b} --> [k1,k2,a,b]
+varSetElemsKvsFirst set
+  = kvs ++ tvs
+  where
+    (kvs, tvs) = partition isKindVar (varSetElems set)
 \end{code}
 
 %************************************************************************