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

Fixed conflicts:
	compiler/typecheck/TcSMonad.lhs

28 files changed, 1260 insertions, 260 deletions

diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 55a5b73ac5..869bc1b4ac 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -4,7 +4,7 @@ module CmmExpr
     , CmmReg(..), cmmRegType
     , CmmLit(..), cmmLitType
     , LocalReg(..), localRegType
-    , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node
+    , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
     , VGcPtr(..), vgcFlag 	-- Temporary!
     , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
     , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
@@ -425,7 +425,8 @@ instance Ord GlobalReg where
    compare _ EagerBlackholeInfo = GT
 
 -- convenient aliases
-spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg = CmmGlobal BaseReg
 spReg = CmmGlobal Sp
 hpReg = CmmGlobal Hp
 spLimReg = CmmGlobal SpLim
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index fd440e9136..c5a6644aba 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -10,13 +10,17 @@ module CgPrimOp (
    cgPrimOp
  ) where
 
+import BasicTypes
 import ForeignCall
 import ClosureInfo
 import StgSyn
 import CgForeignCall
 import CgBindery
 import CgMonad
+import CgHeapery
 import CgInfoTbls
+import CgTicky
+import CgProf
 import CgUtils
 import OldCmm
 import CLabel
@@ -205,6 +209,19 @@ emitPrimOp [res] UnsafeFreezeArrayOp [arg] _
 emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _
    = stmtC (CmmAssign (CmmLocal res) arg)
 
+emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] live =
+    doCopyArrayOp src src_off dst dst_off n live
+emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live =
+    doCopyMutableArrayOp src src_off dst dst_off n live
+emitPrimOp [res] CloneArrayOp [src,src_off,n] live =
+    emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
+emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] live =
+    emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
+emitPrimOp [res] FreezeArrayOp [src,src_off,n] live =
+    emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live
+emitPrimOp [res] ThawArrayOp [src,src_off,n] live =
+    emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live
+
 -- Reading/writing pointer arrays
 
 emitPrimOp [r] ReadArrayOp  [obj,ix]   _  = doReadPtrArrayOp r obj ix
@@ -618,3 +635,198 @@ cmmLoadIndexOffExpr off rep base idx
 setInfo :: CmmExpr -> CmmExpr -> CmmStmt
 setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr
 
+-- ----------------------------------------------------------------------------
+-- Copying pointer arrays
+
+-- | Takes a source 'Array#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy.  Copies the given number of
+-- elements from the source array to the destination array.
+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+              -> StgLiveVars -> Code
+doCopyArrayOp = emitCopyArray copy
+  where
+    -- Copy data (we assume the arrays aren't overlapping since
+    -- they're of different types)
+    copy _src _dst = emitMemcpyCall
+
+-- | Takes a source 'MutableArray#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy.  Copies the given number of
+-- elements from the source array to the destination array.
+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                     -> StgLiveVars -> Code
+doCopyMutableArrayOp = emitCopyArray copy
+  where
+    -- The only time the memory might overlap is when the two arrays
+    -- we were provided are the same array!
+    -- TODO: Optimize branch for common case of no aliasing.
+    copy src dst dst_p src_p bytes live =
+        emitIfThenElse (cmmEqWord src dst)
+        (emitMemmoveCall dst_p src_p bytes live)
+        (emitMemcpyCall dst_p src_p bytes live)
+
+emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                  -> StgLiveVars -> Code)
+              -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+              -> StgLiveVars
+              -> Code
+emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do
+    -- Assign the arguments to temporaries so the code generator can
+    -- calculate liveness for us.
+    src <- assignTemp_ src0
+    src_off <- assignTemp_ src_off0
+    dst <- assignTemp_ dst0
+    dst_off <- assignTemp_ dst_off0
+    n <- assignTemp_ n0
+
+    -- Set the dirty bit in the header.
+    stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+
+    dst_elems_p <- assignTemp $ cmmOffsetB dst arrPtrsHdrSize
+    dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off
+    src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off
+    bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE))
+
+    copy src dst dst_p src_p bytes live
+
+    -- The base address of the destination card table
+    dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst)
+
+    emitSetCards dst_off dst_cards_p n live
+
+-- | Takes an info table label, a register to return the newly
+-- allocated array in, a source array, an offset in the source array,
+-- and the number of elements to copy.  Allocates a new array and
+-- initializes it form the source array.
+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr
+               -> StgLiveVars -> Code
+emitCloneArray info_p res_r src0 src_off0 n0 live = do
+    -- Assign the arguments to temporaries so the code generator can
+    -- calculate liveness for us.
+    src <- assignTemp_ src0
+    src_off <- assignTemp_ src_off0
+    n <- assignTemp_ n0
+
+    card_words <- assignTemp $ (n `cmmUShrWord`
+                                (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
+                  `cmmAddWord` CmmLit (mkIntCLit 1)
+    size <- assignTemp $ n `cmmAddWord` card_words
+    words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size
+
+    arr_r <- newTemp bWord
+    emitAllocateCall arr_r myCapability words live
+    tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize)
+        (CmmLit $ mkIntCLit 0)
+
+    let arr = CmmReg (CmmLocal arr_r)
+    emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr
+    stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+                                      oFFSET_StgMutArrPtrs_ptrs)) n
+    stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE +
+                                      oFFSET_StgMutArrPtrs_size)) size
+
+    dst_p <- assignTemp $ cmmOffsetB arr arrPtrsHdrSize
+    src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize)
+             src_off
+
+    emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) live
+
+    emitMemsetCall (cmmOffsetExprW dst_p n)
+        (CmmLit (CmmInt (toInteger (1 :: Int)) W8))
+        (card_words `cmmMulWord` wordSize)
+        live
+    stmtC $ CmmAssign (CmmLocal res_r) arr
+  where
+    arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize +
+                      (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
+    wordSize = CmmLit (mkIntCLit wORD_SIZE)
+    myCapability = CmmReg baseReg `cmmSubWord`
+                   CmmLit (mkIntCLit oFFSET_Capability_r)
+
+-- | Takes and offset in the destination array, the base address of
+-- the card table, and the number of elements affected (*not* the
+-- number of cards).  Marks the relevant cards as dirty.
+emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitSetCards dst_start dst_cards_start n live = do
+    start_card <- assignTemp $ card dst_start
+    emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
+        (CmmLit (CmmInt (toInteger (1 :: Int)) W8))
+        ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
+         `cmmAddWord` CmmLit (mkIntCLit 1))
+        live
+  where
+    -- Convert an element index to a card index
+    card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- | Emit a call to @memcpy@.
+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemcpyCall dst src n live = do
+    vols <- getVolatileRegs live
+    emitForeignCall' PlayRisky
+        [{-no results-}]
+        (CmmCallee memcpy CCallConv)
+        [ (CmmHinted dst AddrHint)
+        , (CmmHinted src AddrHint)
+        , (CmmHinted n NoHint)
+        ]
+        (Just vols)
+        NoC_SRT -- No SRT b/c we do PlayRisky
+        CmmMayReturn
+  where
+    memcpy = CmmLit (CmmLabel (mkForeignLabel (fsLit "memcpy") Nothing
+                               ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @memmove@.
+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemmoveCall dst src n live = do
+    vols <- getVolatileRegs live
+    emitForeignCall' PlayRisky
+        [{-no results-}]
+        (CmmCallee memmove CCallConv)
+        [ (CmmHinted dst AddrHint)
+        , (CmmHinted src AddrHint)
+        , (CmmHinted n NoHint)
+        ]
+        (Just vols)
+        NoC_SRT -- No SRT b/c we do PlayRisky
+        CmmMayReturn
+  where
+    memmove = CmmLit (CmmLabel (mkForeignLabel (fsLit "memmove") Nothing
+                               ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @memset@.  The second argument must be of type
+-- 'W8'.
+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitMemsetCall dst c n live = do
+    vols <- getVolatileRegs live
+    emitForeignCall' PlayRisky
+        [{-no results-}]
+        (CmmCallee memset CCallConv)
+        [ (CmmHinted dst AddrHint)
+        , (CmmHinted c NoHint)
+        , (CmmHinted n NoHint)
+        ]
+        (Just vols)
+        NoC_SRT -- No SRT b/c we do PlayRisky
+        CmmMayReturn
+  where
+    memset = CmmLit (CmmLabel (mkForeignLabel (fsLit "memset") Nothing
+                               ForeignLabelInExternalPackage IsFunction))
+
+-- | Emit a call to @allocate@.
+emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code
+emitAllocateCall res cap n live = do
+    vols <- getVolatileRegs live
+    emitForeignCall' PlayRisky
+        [CmmHinted res AddrHint]
+        (CmmCallee allocate CCallConv)
+        [ (CmmHinted cap AddrHint)
+        , (CmmHinted n NoHint)
+        ]
+        (Just vols)
+        NoC_SRT -- No SRT b/c we do PlayRisky
+        CmmMayReturn
+  where
+    allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing
+                                 ForeignLabelInExternalPackage IsFunction))
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 922d330b26..4df7c77914 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -20,7 +20,7 @@ module CgUtils (
         emitRODataLits, mkRODataLits,
         emitIf, emitIfThenElse,
 	emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
-	assignTemp, newTemp,
+	assignTemp, assignTemp_, newTemp,
 	emitSimultaneously,
 	emitSwitch, emitLitSwitch,
 	tagToClosure,
@@ -29,7 +29,7 @@ module CgUtils (
 	activeStgRegs, fixStgRegisters,
 
 	cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
-        cmmUGtWord,
+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
 	cmmOffsetExprW, cmmOffsetExprB,
 	cmmRegOffW, cmmRegOffB,
 	cmmLabelOffW, cmmLabelOffB,
@@ -180,8 +180,10 @@ cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
+cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
+cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
 
 cmmNegate :: CmmExpr -> CmmExpr
 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
@@ -587,6 +589,9 @@ mkByteStringCLit bytes
 --
 -------------------------------------------------------------------------
 
+-- | If the expression is trivial, return it.  Otherwise, assign the
+-- expression to a temporary register and return an expression
+-- referring to this register.
 assignTemp :: CmmExpr -> FCode CmmExpr
 -- For a non-trivial expression, e, create a local
 -- variable and assign the expression to it
@@ -596,6 +601,14 @@ assignTemp e
 			    ; stmtC (CmmAssign (CmmLocal reg) e)
 			    ; return (CmmReg (CmmLocal reg)) }
 
+-- | Assign the expression to a temporary register and return an
+-- expression referring to this register.
+assignTemp_ :: CmmExpr -> FCode CmmExpr
+assignTemp_ e = do
+    reg <- newTemp (cmmExprType e)
+    stmtC (CmmAssign (CmmLocal reg) e)
+    return (CmmReg (CmmLocal reg))
+
 newTemp :: CmmType -> FCode LocalReg
 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
 
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 49f7a97a61..69a12745fb 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -626,6 +626,49 @@ primop  UnsafeThawArrayOp  "unsafeThawArray#" GenPrimOp
    out_of_line = True
    has_side_effects = True
 
+primop  CopyArrayOp "copyArray#" GenPrimOp
+  Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+  {Copy a range of the Array# to the specified region in the MutableArray#.
+   Both arrays must fully contain the specified ranges, but this is not checked.
+   The two arrays must not be the same array in different states, but this is not checked either.}
+  with
+  has_side_effects = True
+
+primop  CopyMutableArrayOp "copyMutableArray#" GenPrimOp
+  MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s
+  {Copy a range of the first MutableArray# to the specified region in the second MutableArray#.
+   Both arrays must fully contain the specified ranges, but this is not checked.}
+  with
+  has_side_effects = True
+
+primop  CloneArrayOp "cloneArray#" GenPrimOp
+  Array# a -> Int# -> Int# -> Array# a
+  {Return a newly allocated Array# with the specified subrange of the provided Array#. 
+   The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  has_side_effects = True
+
+primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp
+  MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+  {Return a newly allocated Array# with the specified subrange of the provided Array#.
+   The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  has_side_effects = True
+
+primop  FreezeArrayOp "freezeArray#" GenPrimOp
+  MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #)
+  {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+   The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  has_side_effects = True
+
+primop  ThawArrayOp "thawArray#" GenPrimOp
+  Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #)
+  {Return a newly allocated Array# with the specified subrange of the provided MutableArray#.
+   The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.}
+  with
+  has_side_effects = True
+
 ------------------------------------------------------------------------
 section "Byte Arrays"
 	{Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index 5474cfa3cb..378bbd607d 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -547,7 +547,7 @@ tidyFlavoredEvVar env (EvVarX v fl)
   = EvVarX (tidyEvVar env v) (tidyFlavor env fl)
 
 tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
-tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
+tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk
 tidyFlavor _   fl          = fl
 
 tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
@@ -591,8 +591,8 @@ substFlavoredEvVar subst (EvVarX v fl)
   = EvVarX (substEvVar subst v) (substFlavor subst fl)
 
 substFlavor :: TvSubst -> CtFlavor -> CtFlavor
-substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
-substFlavor _     fl          = fl
+substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk
+substFlavor _     fl             = fl
 
 substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
 substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
index 44cff5eb93..2cb38a908a 100644
--- a/compiler/typecheck/TcCanonical.lhs
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -93,7 +93,9 @@ 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 :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts)
 -- Coercions :: Xi ~ Type 
@@ -112,7 +114,7 @@ flatten ctxt ty
 	-- Preserve type synonyms if possible
 	-- We can tell if ty' is function-free by
 	-- whether there are any floated constraints
-       ; if isEmptyCCan ccs then
+        ; if isReflCo co then
              return (ty, mkReflCo ty, emptyCCan)
          else
              return (xi, co, ccs) }
@@ -140,7 +142,7 @@ flatten fl (TyConApp tc tys)
   -- 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 
+  | otherwise
   = ASSERT( tyConArity tc <= length tys )	-- Type functions are saturated
       do { (xis, cos, ccs) <- flattenMany fl tys
          ; let (xi_args, xi_rest)  = splitAt (tyConArity tc) xis
@@ -148,37 +150,41 @@ flatten fl (TyConApp tc tys)
 	       	 -- The type function might be *over* saturated
 		 -- in which case the remaining arguments should
 		 -- be dealt with by AppTys
-               fam_ty = mkTyConApp tc xi_args 
-               fam_co = mkReflCo fam_ty -- identity
-
-         ; (ret_co, rhs_var, ct) <- 
-             if isGiven fl then
-               do { rhs_var <- newFlattenSkolemTy fam_ty
-                  ; cv <- newGivenCoVar fam_ty rhs_var fam_co
-                  ; let ct = CFunEqCan { cc_id     = cv
-                                       , cc_flavor = fl -- Given
-                                       , cc_fun    = tc 
-                                       , cc_tyargs = xi_args 
-                                       , cc_rhs    = rhs_var }
-                  ; return $ (mkCoVarCo cv, rhs_var, ct) }
-             else -- Derived or Wanted: make a new *unification* flatten variable
-               do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
-                  ; cv <- newCoVar fam_ty rhs_var
-                  ; let ct = CFunEqCan { cc_id = cv
-                                       , cc_flavor = mkWantedFlavor fl
-                                           -- Always Wanted, not Derived
-                                       , cc_fun = tc
-                                       , cc_tyargs = xi_args
-                                       , cc_rhs    = rhs_var }
-                  ; return $ (mkCoVarCo cv, rhs_var, ct) }
-
+               fam_ty = mkTyConApp tc xi_args
+         ; (ret_co, rhs_var, ct) <-
+             do { is_cached <- lookupFlatCacheMap tc xi_args fl 
+                ; case is_cached of 
+                    Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan)
+                    Nothing
+                        | isGivenOrSolved fl ->
+                            do { rhs_var <- newFlattenSkolemTy fam_ty
+                               ; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty)
+                               ; let ct = CFunEqCan { cc_id     = cv
+                                                    , cc_flavor = fl -- Given
+                                                    , cc_fun    = tc 
+                                                    , cc_tyargs = xi_args 
+                                                    , cc_rhs    = rhs_var }
+                               ; let ret_co = mkCoVarCo cv 
+                               ; updateFlatCacheMap tc xi_args rhs_var fl ret_co 
+                               ; return $ (ret_co, rhs_var, singleCCan ct) }
+                        | otherwise ->
+                    -- Derived or Wanted: make a new *unification* flatten variable
+                            do { rhs_var <- newFlexiTcSTy (typeKind fam_ty)
+                               ; cv <- newCoVar fam_ty rhs_var
+                               ; let ct = CFunEqCan { cc_id = cv
+                                                    , cc_flavor = mkWantedFlavor fl
+                                                    -- Always Wanted, not Derived
+                                                    , cc_fun = tc
+                                                    , cc_tyargs = xi_args
+                                                    , cc_rhs    = rhs_var }
+                               ; let ret_co = mkCoVarCo cv
+                               ; updateFlatCacheMap tc xi_args rhs_var fl ret_co
+                               ; return $ (ret_co, rhs_var, singleCCan ct) } }
          ; return ( foldl AppTy rhs_var xi_rest
-                  , foldl mkAppCo
-                          (mkSymCo ret_co
-                            `mkTransCo` mkTyConAppCo tc cos_args)
-                          cos_rest
-                  , ccs `extendCCans` ct) }
-
+                  , foldl AppCo (mkSymCo ret_co 
+                                   `mkTransCo` mkTyConAppCo tc cos_args) 
+                                cos_rest
+                  , ccs `andCCan` ct) }
 
 flatten ctxt (PredTy pred) 
   = do { (pred', co, ccs) <- flattenPred ctxt pred
@@ -223,7 +229,7 @@ canWanteds :: [WantedEvVar] -> TcS WorkList
 canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev)
 
 canGivens :: GivenLoc -> [EvVar] -> TcS WorkList
-canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens
+canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens
                           ; return (unionWorkLists ccs) }
 
 mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList
@@ -239,6 +245,7 @@ mkCanonicalFEVs = foldrBagM canon_one emptyWorkList
     canon_one fev wl = do { wl' <- mkCanonicalFEV fev
                           ; return (unionWorkList wl' wl) }
 
+
 mkCanonical :: CtFlavor -> EvVar -> TcS WorkList
 mkCanonical fl ev = case evVarPred ev of 
                         ClassP clas tys -> canClassToWorkList fl ev clas tys 
@@ -249,15 +256,15 @@ mkCanonical fl ev = case evVarPred ev of
 canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList
 canClassToWorkList fl v cn tys 
   = do { (xis,cos,ccs) <- flattenMany fl tys  -- cos :: xis ~ tys
-       ; let no_flattening_happened = isEmptyCCan ccs
+       ; let no_flattening_happened = all isReflCo cos
              dict_co = mkTyConAppCo (classTyCon cn) cos
-       ; v_new <- if no_flattening_happened then return v
-                  else if isGiven fl        then return v
+       ; v_new <- if no_flattening_happened  then return v
+                  else if isGivenOrSolved fl then return v
                          -- The cos are all identities if fl=Given,
                          -- hence nothing to do
                   else do { v' <- newDictVar cn xis  -- D xis
                           ; when (isWanted fl) $ setDictBind v  (EvCast v' dict_co)
-                          ; when (isGiven fl)  $ setDictBind v' (EvCast v (mkSymCo dict_co))
+                          ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co))
                                  -- NB: No more setting evidence for derived now 
                           ; return v' }
 
@@ -321,7 +328,7 @@ For Deriveds:
 
 Here's an example that demonstrates why we chose to NOT add
 superclasses during simplification: [Comes from ticket #4497]
-
+ 
    class Num (RealOf t) => Normed t
    type family RealOf x
 
@@ -347,14 +354,18 @@ newSCWorkFromFlavored ev orig_flavor cls xis
   = return emptyWorkList  -- Deriveds don't yield more superclasses because we will
                           -- add them transitively in the case of wanteds. 
 
-  | isGiven orig_flavor 
-  = do { let sc_theta = immSuperClasses cls xis 
-             flavor   = orig_flavor
-       ; sc_vars <- mapM newEvVar sc_theta
-       ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
-       ; mkCanonicals flavor sc_vars }
-
-  | isEmptyVarSet (tyVarsOfTypes xis) 
+  | Just gk <- isGiven_maybe orig_flavor 
+  = case gk of 
+      GivenOrig -> do { let sc_theta = immSuperClasses cls xis 
+                            flavor   = orig_flavor
+                      ; sc_vars <- mapM newEvVar sc_theta
+                      ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]]
+                      ; mkCanonicals flavor sc_vars }
+      GivenSolved -> return emptyWorkList 
+      -- Seems very dangerous to add the superclasses for dictionaries that may be 
+      -- partially solved because we may end up with evidence loops.
+
+  | isEmptyVarSet (tyVarsOfTypes xis)
   = return emptyWorkList -- Wanteds with no variables yield no deriveds.
                          -- See Note [Improvement from Ground Wanteds]
 
@@ -417,8 +428,7 @@ canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
                     ; setCoBind cv $ 
                       mkFunCo (mkCoVarCo argv) (mkCoVarCo resv) 
                     ; return (argv,resv) } 
-
-             else if isGiven fl then 
+             else if isGivenOrSolved fl then 
                       let [arg,res] = decomposeCo 2 (mkCoVarCo cv) 
                       in do { argv <- newGivenCoVar s1 s2 arg 
                             ; resv <- newGivenCoVar t1 t2 res
@@ -452,10 +462,9 @@ canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2)
                     do { argsv <- zipWithM newCoVar tys1 tys2
                        ; setCoBind cv $ 
                          mkTyConAppCo tc1 (map mkCoVarCo argsv)
-                       ; return argsv } 
-
-                else if isGiven fl then 
-                    let cos = decomposeCo (length tys1) (mkCoVarCo cv) 
+                       ; return argsv }
+                else if isGivenOrSolved fl then
+                    let cos = decomposeCo (length tys1) (mkCoVarCo cv)
                     in zipWith3M newGivenCoVar tys1 tys2 cos
 
                 else -- Derived 
@@ -691,7 +700,7 @@ canEqLeaf _untch fl cv cls1 cls2
                 then do { cv' <- newCoVar s2 s1 
                         ; setCoBind cv $ mkSymCo (mkCoVarCo cv') 
                         ; return cv' } 
-                else if isGiven fl then 
+                else if isGivenOrSolved fl then
                          newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv))
                 else -- Derived
                     newDerivedId (EqPred s2 s1)
@@ -723,9 +732,9 @@ canEqLeafOriented fl cv cls1@(FunCls fn tys1) s2         -- cv : F tys1
        ; (xi2, co2, ccs2) <- flatten fl s2       -- Flatten entire RHS
                                                  -- co2  :: xi2 ~ s2
        ; let ccs = ccs1 `andCCan` ccs2
-             no_flattening_happened = isEmptyCCan ccs
-       ; cv_new <- if no_flattening_happened then return cv
-                   else if isGiven fl        then return cv
+             no_flattening_happened = all isReflCo (co2:cos1)
+       ; cv_new <- if no_flattening_happened  then return cv
+                   else if isGivenOrSolved fl then return cv
                    else if isWanted fl then 
                          do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2
                                  -- cv' : F xis ~ xi2
@@ -769,9 +778,9 @@ canEqLeafTyVarLeft fl cv tv s2       -- cv : tv ~ s2
        ; case mxi2' of {
            Nothing   -> canEqFailure fl cv ;
            Just xi2' ->
-    do { let no_flattening_happened = isEmptyCCan ccs2
-       ; cv_new <- if no_flattening_happened then return cv
-                   else if isGiven fl        then return cv
+    do { let no_flattening_happened = isReflCo co
+       ; cv_new <- if no_flattening_happened  then return cv
+                   else if isGivenOrSolved fl then return cv
                    else if isWanted fl then 
                          do { cv' <- newCoVar (mkTyVarTy tv) xi2'  -- cv' : tv ~ xi2
                             ; setCoBind cv  (mkCoVarCo cv' `mkTransCo` co)
@@ -997,7 +1006,7 @@ instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
        ; mapM (do_one subst) eqs }
   where 
     fl' = case fl of 
-             Given _     -> panic "mkFunDepEqns"
+             Given {}    -> panic "mkFunDepEqns"
              Wanted  loc -> Wanted  (push_ctx loc)
              Derived loc -> Derived (push_ctx loc)
 
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 0d0a9f8e08..b199053ac2 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -16,6 +16,7 @@ import TcSMonad
 import TcType
 import TypeRep
 import Type( isTyVarTy )
+import Unify ( tcMatchTys )
 import Inst
 import InstEnv
 import TyCon
@@ -104,7 +105,7 @@ reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = impli
                        -- because they are unconditionally wrong
                        -- Moreover, if any of the insolubles are givens, stop right there
                        -- ignoring nested errors, because the code is inaccessible
-  = do { let (given, other) = partitionBag (isGiven . evVarX) insols
+  = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols
              insol_implics  = filterBag ic_insol implics
        ; if isEmptyBag given
          then do { mapBagM_ (reportInsoluble ctxt) other
@@ -152,7 +153,8 @@ reportInsoluble ctxt (EvVarX ev flav)
   | otherwise
   = pprPanic "reportInsoluble" (pprEvVarWithType ev)
   where
-    inaccessible_msg | Given loc <- flav
+    inaccessible_msg | Given loc GivenOrig <- flav
+                       -- If a GivenSolved then we should not report inaccessible code
                      = hang (ptext (sLit "Inaccessible code in"))
                           2 (ppr (ctLocOrigin loc))
                      | otherwise = empty
@@ -418,18 +420,18 @@ couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc
 couldNotDeduce givens (wanteds, orig)
   = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds)
               2 (pprArising orig)
-         , vcat pp_givens ]
-  where
-    pp_givens
-      = case givens of
+         , vcat (pp_givens givens)]
+
+pp_givens :: [([EvVar], GivenLoc)] -> [SDoc]
+pp_givens givens 
+   = case givens of
          []     -> []
          (g:gs) ->      ppr_given (ptext (sLit "from the context")) g
                  : map (ppr_given (ptext (sLit "or from"))) gs
-
-    ppr_given herald (gs,loc)
-      = hang (herald <+> pprEvVarTheta gs)
-           2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
-                  , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
+    where ppr_given herald (gs,loc)
+           = hang (herald <+> pprEvVarTheta gs)
+                2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc)
+                       , ptext (sLit "at") <+> ppr (ctLocSpan loc)])
 
 addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt
 -- Add on extra info about the types themselves
@@ -575,18 +577,58 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys)
 				<+> pprPredTy pred)
     	     ,	sep [ptext (sLit "Matching instances") <> colon,
     		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
+
+             ,  if not (null overlapping_givens) then 
+                  sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)]
+                else empty
+
+             ,  if null overlapping_givens && isSingleton matches && null unifiers then
+                -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities) 
+                -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten
+                -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem.
+                  sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))]
+                else empty 
+
 	     ,	if not (isSingleton matches)
     		then 	-- Two or more matches
 		     empty
     		else 	-- One match, plus some unifiers
 		ASSERT( not (null unifiers) )
 		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
-                                 quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
-			      ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
-			      ptext (sLit "when compiling the other instance declarations")])]
+	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
+			      if null (overlapping_givens) then
+                                   vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+			                  ptext (sLit "when compiling the other instance declarations")]
+                              else empty])]
       where
     	ispecs = [ispec | (ispec, _) <- matches]
 
+        givens = getUserGivens ctxt
+        overlapping_givens = unifiable_givens givens
+
+        unifiable_givens [] = [] 
+        unifiable_givens (gg:ggs) 
+          | Just ggdoc <- matchable gg 
+          = ggdoc : unifiable_givens ggs 
+          | otherwise 
+          = unifiable_givens ggs 
+
+        matchable (evvars,gloc) 
+          = case ev_vars_matching of
+                 [] -> Nothing
+                 _  -> Just $ hang (pprTheta ev_vars_matching)
+                                2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc)
+                                       , ptext (sLit "at") <+> ppr (ctLocSpan gloc)])
+            where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+                  ev_var_matches (ClassP clas' tys')
+                    | clas' == clas
+                    , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys'
+                    = True 
+                  ev_var_matches (ClassP clas' tys') =
+                    any ev_var_matches (immSuperClasses clas' tys')
+                  ev_var_matches _ = False
+
+
 reportOverlap _ _ _ _ = panic "reportOverlap"    -- Not a ClassP
 
 ----------------------
@@ -832,9 +874,9 @@ flattenForAllErrorTcS fl ty _bad_eqs
 
 \begin{code}
 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc)   thing = setCtLoc loc thing
+setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index c2e9bc8921..bb0089f8e2 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -795,6 +795,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ 
     do {  -- Instantiate the instance decl with skolem constants
        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
+                     -- We instantiate the dfun_id with superSkolems.
+                     -- See Note [Subtle interaction of recursion and overlap]
+                     -- and Note [Binding when looking up instances]
        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
              (class_tyvars, sc_theta, _, op_items) = classBigSig clas
              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
@@ -873,7 +876,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                  listToBag meth_binds)
        }
  where
-   skol_info = InstSkol         -- See Note [Subtle interaction of recursion and overlap]
+   skol_info = InstSkol         
    dfun_ty   = idType dfun_id
    dfun_id   = instanceDFunId ispec
    loc       = getSrcSpan dfun_id
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index fd66d0ac0c..3833534f1e 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -12,6 +12,7 @@ import BasicTypes
 import TcCanonical
 import VarSet
 import Type
+import Unify
 
 import Id 
 import Var
@@ -30,6 +31,7 @@ import Coercion
 import Outputable
 
 import TcRnTypes
+import TcMType ( isSilentEvVar )
 import TcErrors
 import TcSMonad
 import Bag
@@ -68,8 +70,11 @@ An InertSet is a bag of canonical constraints, with the following invariants:
     will be marked as solved right before being pushed into the inert set. 
     See note [Touchables and givens].
 
-  8 No Given constraint mentions a touchable unification variable,
-    except if the
+  8 No Given constraint mentions a touchable unification variable, but 
+    Given/Solved may do so. 
+
+  9 Given constraints will also have their superclasses in the inert set, 
+    but Given/Solved will not. 
  
 Note that 6 and 7 are /not/ enforced by canonicalization but rather by 
 insertion in the inert list, ie by TcInteract. 
@@ -192,7 +197,7 @@ extractUnsolved is@(IS {inert_eqs = eqs})
                         , inert_funeqs = solved_funeqs }
     in (is_solved, unsolved)
 
-  where (unsolved_eqs, solved_eqs)       = Bag.partitionBag (not.isGivenCt) eqs
+  where (unsolved_eqs, solved_eqs)       = Bag.partitionBag (not.isGivenOrSolvedCt) eqs
         (unsolved_ips, solved_ips)       = extractUnsolvedCMap (inert_ips is) 
         (unsolved_dicts, solved_dicts)   = extractUnsolvedCMap (inert_dicts is) 
         (unsolved_funeqs, solved_funeqs) = extractUnsolvedCMap (inert_funeqs is) 
@@ -327,7 +332,7 @@ solveInteractGiven inert gloc evs
                            map mk_given evs
        ; return inert_ret }
   where
-    flav = Given gloc
+    flav = Given gloc GivenOrig
     mk_given ev = mkEvVarX ev flav
 
 solveInteractWanted :: InertSet -> [WantedEvVar] -> TcS InertSet
@@ -527,7 +532,7 @@ spontaneousSolveStage depth workItem inerts
                            , sr_stop       = ContinueWith workItem }
 
            SPSolved workItem'
-               | not (isGivenCt workItem) 
+               | not (isGivenOrSolvedCt workItem) 
 	       	 -- Original was wanted or derived but we have now made him 
                  -- given so we have to interact him with the inerts due to
                  -- its status change. This in turn may produce more work.
@@ -568,7 +573,7 @@ data SPSolveResult = SPCantSolve | SPSolved WorkItem | SPError
 --     	    See Note [Touchables and givens] 
 trySpontaneousSolve :: WorkItem -> TcS SPSolveResult
 trySpontaneousSolve workItem@(CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi })
-  | isGiven gw
+  | isGivenOrSolved gw
   = return SPCantSolve
   | Just tv2 <- tcGetTyVar_maybe xi
   = do { tch1 <- isTouchableMetaTyVar tv1
@@ -726,9 +731,8 @@ solveWithIdentity cv wd tv xi
 
        ; when (isWanted wd) (setCoBind cv refl_xi)
            -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)'
-
        ; return $ SPSolved (CTyEqCan { cc_id = cv_given
-                                     , cc_flavor = mkGivenFlavor wd UnkSkol
+                                     , cc_flavor = mkSolvedFlavor wd UnkSkol
                                      , cc_tyvar  = tv, cc_rhs = xi }) }
 \end{code}
 
@@ -928,7 +932,7 @@ doInteractWithInert
   | cls1 == cls2 && eqTypes tys1 tys2
   = solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem 
 
-  | cls1 == cls2 && (not (isGiven fl1 && isGiven fl2))
+  | cls1 == cls2 && (not (isGivenOrSolved fl1 && isGivenOrSolved fl2))
   = 	 -- See Note [When improvement happens]
     do { let pty1 = ClassP cls1 tys1
              pty2 = ClassP cls2 tys2
@@ -1032,7 +1036,7 @@ doInteractWithInert (CIPCan { cc_id = ipid, cc_flavor = ifl, cc_ip_nm = nm, cc_i
 -- so we just generate a fresh coercion variable that isn't used anywhere.
 doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) 
            workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
-  | nm1 == nm2 && isGiven wfl && isGiven ifl
+  | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl
   = 	-- See Note [Overriding implicit parameters]
         -- Dump the inert item, override totally with the new one
 	-- Do not require type equality
@@ -1093,6 +1097,13 @@ doInteractWithInert (CFunEqCan { cc_id = cv1, cc_flavor = fl1, cc_fun = tc1
                                , cc_tyargs = args1, cc_rhs = xi1 }) 
            workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
                                , cc_tyargs = args2, cc_rhs = xi2 })
+  | tc1 == tc2 && and (zipWith eqType args1 args2) 
+  , Just GivenSolved <- isGiven_maybe fl1 
+  = mkIRContinue "Funeq/Funeq" workItem DropInert emptyWorkList
+  | tc1 == tc2 && and (zipWith eqType args1 args2) 
+  , Just GivenSolved <- isGiven_maybe fl2 
+  = mkIRStopK "Funeq/Funeq" emptyWorkList
+
   | fl1 `canSolve` fl2 && lhss_match
   = do { cans <- rewriteEqLHS LeftComesFromInert  (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) 
        ; mkIRStopK "FunEq/FunEq" cans } 
@@ -1289,6 +1300,10 @@ solveOneFromTheOther info (ev_term,ifl) workItem
 		  -- so it's safe to continue on from this point
   = mkIRContinue ("Solved[DI] " ++ info) workItem DropInert emptyWorkList
   
+  | Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl
+    -- Same if the inert is a GivenSolved -- just get rid of it
+  = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert emptyWorkList
+
   | otherwise
   = ASSERT( ifl `canSolve` wfl )
       -- Because of Note [The Solver Invariant], plus Derived dealt with
@@ -1663,33 +1678,34 @@ data TopInteractResult
                                         -- only reacted with functional dependencies 
 					-- arising from top-level instances.
 
-topReactionsStage :: SimplifierStage 
-topReactionsStage depth workItem inerts 
-  = do { tir <- tryTopReact workItem 
-       ; case tir of 
-           NoTopInt -> 
-               return $ SR { sr_inerts   = inerts 
-                           , sr_new_work = emptyWorkList 
-                           , sr_stop     = ContinueWith workItem } 
-           SomeTopInt tir_new_work tir_new_inert -> 
+topReactionsStage :: SimplifierStage
+topReactionsStage depth workItem inerts
+  = do { tir <- tryTopReact inerts workItem
+             -- NB: we pass the inerts as well. See Note [Instance and Given overlap]
+       ; case tir of
+           NoTopInt ->
+               return $ SR { sr_inerts   = inerts
+                           , sr_new_work = emptyWorkList
+                           , sr_stop     = ContinueWith workItem }
+           SomeTopInt tir_new_work tir_new_inert ->
                do { bumpStepCountTcS
                   ; traceFireTcS depth (ptext (sLit "Top react")
                        <+> vcat [ ptext (sLit "Work =") <+> ppr workItem
                                 , ptext (sLit "New =") <+> ppr tir_new_work ])
-                  ; return $ SR { sr_inerts   = inerts 
+                  ; return $ SR { sr_inerts   = inerts
                            	, sr_new_work = tir_new_work
                            	, sr_stop     = tir_new_inert
                            	} }
        }
 
-tryTopReact :: WorkItem -> TcS TopInteractResult 
-tryTopReact workitem 
+tryTopReact :: InertSet -> WorkItem -> TcS TopInteractResult 
+tryTopReact inerts workitem 
   = do {  -- A flag controls the amount of interaction allowed
           -- See Note [Simplifying RULE lhs constraints]
          ctxt <- getTcSContext
        ; if allowedTopReaction (simplEqsOnly ctxt) workitem 
          then do { traceTcS "tryTopReact / calling doTopReact" (ppr workitem)
-                 ; doTopReact workitem }
+                 ; doTopReact inerts workitem }
          else return NoTopInt 
        } 
 
@@ -1697,7 +1713,7 @@ allowedTopReaction :: Bool -> WorkItem -> Bool
 allowedTopReaction eqs_only (CDictCan {}) = not eqs_only
 allowedTopReaction _        _             = True
 
-doTopReact :: WorkItem -> TcS TopInteractResult 
+doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult
 -- The work item does not react with the inert set, so try interaction with top-level instances
 -- NB: The place to add superclasses in *not* in doTopReact stage. Instead superclasses are 
 --     added in the worklist as part of the canonicalisation process. 
@@ -1705,12 +1721,12 @@ doTopReact :: WorkItem -> TcS TopInteractResult
 
 -- Given dictionary
 -- See Note [Given constraint that matches an instance declaration]
-doTopReact (CDictCan { cc_flavor = Given {} })
+doTopReact _inerts (CDictCan { cc_flavor = Given {} })
   = return NoTopInt -- NB: Superclasses already added since it's canonical
 
 -- Derived dictionary: just look for functional dependencies
-doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc)
-                              , cc_class = cls, cc_tyargs = xis })
+doTopReact _inerts workItem@(CDictCan { cc_flavor = fl@(Derived loc)
+                                      , cc_class = cls, cc_tyargs = xis })
   = do { instEnvs <- getInstEnvs
        ; let fd_eqns = improveFromInstEnv instEnvs
                                                 (ClassP cls xis, pprArisingAt loc)
@@ -1724,10 +1740,10 @@ doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc)
                                       , tir_new_inert = ContinueWith workItem' } }
 
 -- Wanted dictionary
-doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
-                              , cc_class = cls, cc_tyargs = xis })
+doTopReact inerts workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
+                                     , cc_class = cls, cc_tyargs = xis })
   = do { -- See Note [MATCHING-SYNONYMS]
-       ; lkp_inst_res <- matchClassInst cls xis loc
+       ; lkp_inst_res <- matchClassInst inerts cls xis loc
        ; case lkp_inst_res of
            NoInstance ->
              do { traceTcS "doTopReact/ no class instance for" (ppr dv)
@@ -1753,7 +1769,7 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
 		   -- matches already so we won't get any more info
 		   -- from functional dependencies
              | null wtvs
-             -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv) 
+             -> do { traceTcS "doTopReact/found nullary class instance for" (ppr dv) 
                    ; setDictBind dv ev_term 
                     -- Solved in one step and no new wanted work produced. 
                     -- i.e we directly matched a top-level instance
@@ -1762,25 +1778,29 @@ doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc)
                                          , tir_new_inert = Stop } }
 
              | otherwise
-             -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv) 
+             -> do { traceTcS "doTopReact/found non-nullary class instance for" (ppr dv) 
                    ; setDictBind dv ev_term 
                         -- Solved and new wanted work produced, you may cache the 
-                        -- (tentatively solved) dictionary as Given! (used to be: Derived)
-                   ; let solved   = workItem { cc_flavor = given_fl }
-                         given_fl = Given (setCtLocOrigin loc UnkSkol) 
+                        -- (tentatively solved) dictionary as Solved given.
+                   ; let solved    = workItem { cc_flavor = solved_fl }
+                         solved_fl = mkSolvedFlavor fl UnkSkol  
                    ; inst_work <- canWanteds wtvs
                    ; return $ SomeTopInt { tir_new_work  = inst_work
                                          , tir_new_inert = ContinueWith solved } }
        }          
 
 -- Type functions
-doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
-                      , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
+doTopReact _inerts (CFunEqCan { cc_flavor = fl })
+  | Just GivenSolved <- isGiven_maybe fl
+  = return NoTopInt -- If Solved, no more interactions should happen
+
+-- Otherwise, it's a Given, Derived, or Wanted
+doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl
+                                       , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
   = ASSERT (isSynFamilyTyCon tc)   -- No associated data families have reached that far 
     do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS]
        ; case match_res of 
-           MatchInstNo 
-             -> return NoTopInt 
+           MatchInstNo -> return NoTopInt 
            MatchInstSingle (rep_tc, rep_tys)
              -> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc
                          Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys)
@@ -1788,25 +1808,40 @@ doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
 			    -- RHS of a type function, so that it never
 			    -- appears in an error message
                             -- See Note [Type synonym families] in TyCon
-                         coe = mkAxInstCo coe_tc rep_tys
-                   ; cv' <- case fl of
-                              Wanted {} -> do { cv' <- newCoVar rhs_ty xi
-                                              ; setCoBind cv $ 
-                                                    coe `mkTransCo`
-                                                      mkCoVarCo cv'
-                                              ; return cv' }
-                              Given {}   -> newGivenCoVar xi rhs_ty $ 
-                                            mkSymCo (mkCoVarCo cv) `mkTransCo` coe 
-                              Derived {} -> newDerivedId (EqPred xi rhs_ty)
-                   ; can_cts <- mkCanonical fl cv'
-                   ; return $ SomeTopInt can_cts Stop }
+                         coe = mkAxInstCo coe_tc rep_tys 
+                   ; case fl of
+                       Wanted {} -> do { cv' <- newCoVar rhs_ty xi
+                                       ; setCoBind cv $ coe `mkTransCo` mkCoVarCo cv'
+                                       ; can_cts <- mkCanonical fl cv'
+                                       ; let solved = workItem { cc_flavor = solved_fl }
+                                             solved_fl = mkSolvedFlavor fl UnkSkol
+                                       ; if isEmptyWorkList can_cts then 
+                                              return (SomeTopInt can_cts Stop) -- No point in caching
+                                         else return $ 
+                                              SomeTopInt { tir_new_work = can_cts
+                                                         , tir_new_inert = ContinueWith solved }
+                                       }
+                       Given {} -> do { cv' <- newGivenCoVar xi rhs_ty $ 
+                                               mkSymCo (mkCoVarCo cv) `mkTransCo` coe 
+                                      ; can_cts <- mkCanonical fl cv'
+                                      ; return $ 
+                                        SomeTopInt { tir_new_work = can_cts
+                                                   , tir_new_inert = Stop }
+                                      }
+                       Derived {} -> do { cv' <- newDerivedId (EqPred xi rhs_ty)
+                                        ; can_cts <- mkCanonical fl cv'
+                                        ; return $ 
+                                          SomeTopInt { tir_new_work = can_cts
+                                                     , tir_new_inert = Stop }
+                                        }
+                   }
            _ 
              -> panicTcS $ text "TcSMonad.matchFam returned multiple instances!"
        }
 
 
 -- Any other work item does not react with any top-level equations
-doTopReact _workItem = return NoTopInt 
+doTopReact _inerts _workItem = return NoTopInt 
 \end{code}
 
 
@@ -2010,15 +2045,25 @@ data LookupInstResult
   = NoInstance
   | GenInst [WantedEvVar] EvTerm 
 
-matchClassInst :: Class -> [Type] -> WantedLoc -> TcS LookupInstResult
-matchClassInst clas tys loc
+matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult
+matchClassInst inerts clas tys loc
    = do { let pred = mkClassPred clas tys 
         ; mb_result <- matchClass clas tys
+        ; untch <- getUntouchables
         ; case mb_result of
             MatchInstNo   -> return NoInstance
-            MatchInstMany -> return NoInstance -- defer any reactions of a multitude until 
+            MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
                                                -- we learn more about the reagent 
-            MatchInstSingle (dfun_id, mb_inst_tys) -> 
+            MatchInstSingle (_,_)
+              | given_overlap untch -> 
+                  do { traceTcS "Delaying instance application" $ 
+                       vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys)
+                            , text "Silents and their superclasses=" <+> ppr silents_and_their_scs
+                            , text "All given dictionaries=" <+> ppr all_given_dicts ]
+                     ; return NoInstance -- see Note [Instance and Given overlap]
+                     }
+
+            MatchInstSingle (dfun_id, mb_inst_tys) ->
               do { checkWellStagedDFun pred dfun_id loc
 
  	-- It's possible that not all the tyvars are in
@@ -2027,7 +2072,7 @@ matchClassInst clas tys loc
 	-- (presumably there's a functional dependency in class C)
 	-- Hence mb_inst_tys :: Either TyVar TcType 
 
-                 ; tys <- instDFunTypes mb_inst_tys 
+                 ; tys <- instDFunTypes mb_inst_tys
                  ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
                  ; if null theta then
                        return (GenInst [] (EvDFunApp dfun_id tys []))
@@ -2037,4 +2082,94 @@ matchClassInst clas tys loc
                      ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
                  }
         }
+   where given_overlap :: TcsUntouchables -> Bool
+         given_overlap untch
+           = foldlBag (\r d -> r || matchable untch d) False all_given_dicts
+
+         matchable untch (CDictCan { cc_class = clas', cc_tyargs = sys, cc_flavor = fl })
+           | Just GivenOrig <- isGiven_maybe fl
+           , clas' == clas
+           , does_not_originate_in_a_silent clas' sys
+           = case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv && 
+                                        tv `elemVarSet` tyVarsOfTypes tys
+                                     then BindMe else Skolem) tys sys of
+           -- We can't learn anything more about any variable at this point, so the only
+           -- cause of overlap can be by an instantiation of a touchable unification
+           -- variable. Hence we only bind touchable unification variables. In addition,
+           -- we use tcUnifyTys instead of tcMatchTys to rule out cyclic substitutions.
+                Nothing -> False
+                Just _  -> True
+           | otherwise = False -- No overlap with a solved, already been taken care of 
+                               -- by the overlap check with the instance environment.
+         matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
+
+         does_not_originate_in_a_silent clas sys
+             -- UGLY: See Note [Silent parameters overlapping]
+           = null $ filter (eqPred (ClassP clas sys)) silents_and_their_scs
+
+         silents_and_their_scs 
+           = foldlBag (\acc rvnt -> case rvnt of
+                        CDictCan { cc_id = d, cc_class = c, cc_tyargs = s }
+                         | isSilentEvVar d -> (ClassP c s) : (transSuperClasses c s) ++ acc 
+                        _ -> acc) [] all_given_dicts
+
+         -- TODO:
+         -- When silent parameters will go away we should simply select from 
+         -- the given map of the inert set. 
+         all_given_dicts = Map.fold unionBags emptyCCan (cts_given $ inert_dicts inerts)
+
 \end{code}
+
+Note [Silent parameters overlapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DV 12/05/2011:
+The long-term goal is to completely remove silent superclass
+parameters when checking instance declarations. But until then we must
+make sure that we never prevent the application of an instance
+declaration because of a potential match from a silent parameter --
+after all we are supposed to have solved that silent parameter from
+some instance, anyway! In effect silent parameters behave more like
+Solved than like Given.
+
+A concrete example appears in typecheck/SilentParametersOverlapping.hs
+
+Note [Instance and Given overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Assume that we have an inert set that looks as follows:
+       [Given] D [Int]
+And an instance declaration: 
+       instance C a => D [a]
+A new wanted comes along of the form: 
+       [Wanted] D [alpha]
+
+One possibility is to apply the instance declaration which will leave us 
+with an unsolvable goal (C alpha). However, later on a new constraint may 
+arise (for instance due to a functional dependency between two later dictionaries), 
+that will add the equality (alpha ~ Int), in which case our ([Wanted] D [alpha]) 
+will be transformed to [Wanted] D [Int], which could have been discharged by the given. 
+
+The solution is that in matchClassInst and eventually in topReact, we get back with 
+a matching instance, only when there is no Given in the inerts which is unifiable to
+this particular dictionary.
+
+The end effect is that, much as we do for overlapping instances, we delay choosing a 
+class instance if there is a possibility of another instance OR a given to match our 
+constraint later on. This fixes bugs #4981 and #5002.
+
+This is arguably not easy to appear in practice due to our aggressive prioritization 
+of equality solving over other constraints, but it is possible. I've added a test case 
+in typecheck/should-compile/GivenOverlapping.hs
+
+Moreover notice that our goals here are different than the goals of the top-level 
+overlapping checks. There we are interested in validating the following principle:
+ 
+    If we inline a function f at a site where the same global instance environment
+    is available as the instance environment at the definition site of f then we 
+    should get the same behaviour. 
+
+But for the Given Overlap check our goal is just related to completeness of 
+constraint solving. 
+
+
+
+
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 531ee44ca5..2c01d2300a 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -617,8 +617,8 @@ zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar
 zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) }
 
 zonkFlavor :: CtFlavor -> TcM CtFlavor
-zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') }
-zonkFlavor fl          = return fl
+zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) }
+zonkFlavor fl             = return fl
 
 zonkGivenLoc :: GivenLoc -> TcM GivenLoc
 -- GivenLocs may have unification variables inside them!
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 7d761eb9e0..17e5dcbb94 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -40,11 +40,13 @@ module TcRnTypes(
         Implication(..),
         CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
 	CtOrigin(..), EqOrigin(..), 
-        WantedLoc, GivenLoc, pushErrCtxt,
+        WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,
 
 	SkolemInfo(..),
 
-        CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
+        CtFlavor(..), pprFlavorArising, isWanted, 
+        isGivenOrSolved, isGiven_maybe,
+        isDerived,
         FlavoredEvVar,
 
 	-- Pretty printing
@@ -924,35 +926,37 @@ pprWantedEvVar        (EvVarX v _)   = pprEvVarWithType v
 
 \begin{code}
 data CtFlavor
-  = Given   GivenLoc  -- We have evidence for this constraint in TcEvBinds
-  | Derived WantedLoc 
-                      -- We have evidence for this constraint in TcEvBinds;
-                      --   *however* this evidence can contain wanteds, so 
-                      --   it's valid only provisionally to the solution of
-                      --   these wanteds 
-  | Wanted WantedLoc  -- We have no evidence bindings for this constraint. 
-
--- data DerivedOrig = DerSC | DerInst | DerSelf
--- Deriveds are either superclasses of other wanteds or deriveds, or partially
--- solved wanteds from instances, or 'self' dictionaries containing yet wanted
--- superclasses. 
+  = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
+  | Derived WantedLoc        -- Derived's are just hints for unifications 
+  | Wanted WantedLoc         -- We have no evidence bindings for this constraint. 
+
+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. 
 
 instance Outputable CtFlavor where
-  ppr (Given {})   = ptext (sLit "[G]")
-  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
+pprFlavorArising (Derived wl)   = pprArisingAt wl
 pprFlavorArising (Wanted  wl)   = pprArisingAt wl
-pprFlavorArising (Given gl)     = pprArisingAt gl
+pprFlavorArising (Given gl _)   = pprArisingAt gl
 
 isWanted :: CtFlavor -> Bool
 isWanted (Wanted {}) = True
 isWanted _           = False
 
-isGiven :: CtFlavor -> Bool 
-isGiven (Given {}) = True 
-isGiven _          = False 
+isGivenOrSolved :: CtFlavor -> Bool
+isGivenOrSolved (Given {}) = True
+isGivenOrSolved _ = False
+
+isGiven_maybe :: CtFlavor -> Maybe GivenKind 
+isGiven_maybe (Given _ gk) = Just gk
+isGiven_maybe _            = Nothing
 
 isDerived :: CtFlavor -> Bool 
 isDerived (Derived {}) = True
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 07e61a2793..0992fb971e 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -15,13 +15,15 @@ module TcSMonad (
     CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, 
     deCanonicalise, mkFrozenError,
 
-    isWanted, isGiven, isDerived,
-    isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising,
+    isWanted, isGivenOrSolved, isDerived,
+    isGivenOrSolvedCt, isGivenCt_maybe, 
+    isWantedCt, isDerivedCt, pprFlavorArising,
 
     isFlexiTcsTv,
 
     canRewrite, canSolve,
-    combineCtLoc, mkGivenFlavor, mkWantedFlavor,
+    combineCtLoc, mkSolvedFlavor, mkGivenFlavor,
+    mkWantedFlavor,
     getWantedLoc,
 
     TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality 
@@ -39,6 +41,8 @@ module TcSMonad (
 
     setWantedTyBind,
 
+    lookupFlatCacheMap, updateFlatCacheMap,
+
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
     getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap,
@@ -105,6 +109,9 @@ import HsBinds               -- for TcEvBinds stuff
 import Id 
 import TcRnTypes
 import Data.IORef
+
+import qualified Data.Map as Map
+
 #ifdef DEBUG
 import StaticFlags( opt_PprStyle_Debug )
 import Control.Monad( when )
@@ -334,11 +341,16 @@ getWantedLoc ct
 
 isWantedCt :: CanonicalCt -> Bool
 isWantedCt ct = isWanted (cc_flavor ct)
-isGivenCt :: CanonicalCt -> Bool
-isGivenCt ct = isGiven (cc_flavor ct)
 isDerivedCt :: CanonicalCt -> Bool
 isDerivedCt ct = isDerived (cc_flavor ct)
 
+isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind
+isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct)
+
+isGivenOrSolvedCt :: CanonicalCt -> Bool
+isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct)
+
+
 canSolve :: CtFlavor -> CtFlavor -> Bool 
 -- canSolve ctid1 ctid2 
 -- The constraint ctid1 can be used to solve ctid2 
@@ -363,22 +375,27 @@ canRewrite = canSolve
 
 combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
 -- Precondition: At least one of them should be wanted 
-combineCtLoc (Wanted loc) _    = loc 
-combineCtLoc _ (Wanted loc)    = loc 
-combineCtLoc (Derived loc ) _  = loc 
-combineCtLoc _ (Derived loc )  = loc 
+combineCtLoc (Wanted loc) _    = loc
+combineCtLoc _ (Wanted loc)    = loc
+combineCtLoc (Derived loc ) _  = loc
+combineCtLoc _ (Derived loc )  = loc
 combineCtLoc _ _ = panic "combineCtLoc: both given"
 
-mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
-mkGivenFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk)
-mkGivenFlavor (Given   loc) sk  = Given (setCtLocOrigin loc sk)
+mkSolvedFlavor :: CtFlavor -> SkolemInfo -> 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
 
+mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+mkGivenFlavor (Wanted  loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor (Derived loc) sk  = Given (setCtLocOrigin loc sk) GivenOrig
+mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl
 
 mkWantedFlavor :: CtFlavor -> CtFlavor
 mkWantedFlavor (Wanted  loc) = Wanted loc
 mkWantedFlavor (Derived loc) = Wanted loc
-mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavour" (ppr fl)
+mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl)
 \end{code}
 
 %************************************************************************
@@ -413,10 +430,33 @@ data TcSEnv
                      
       tcs_untch :: TcsUntouchables,
 
-      tcs_ic_depth :: Int,	-- Implication nesting depth
-      tcs_count    :: IORef Int	-- Global step count
+      tcs_ic_depth   :: Int,       -- Implication nesting depth
+      tcs_count      :: IORef Int, -- Global step count
+
+      tcs_flat_map   :: IORef FlatCache
     }
 
+data FlatCache 
+  = FlatCache { givenFlatCache  :: Map.Map FunEqHead (TcType,Coercion,CtFlavor)
+                -- Invariant: all CtFlavors here satisfy isGiven
+              , wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) }
+                -- Invariant: all CtFlavors here satisfy isWanted
+
+emptyFlatCache :: FlatCache
+emptyFlatCache 
+ = FlatCache { givenFlatCache  = Map.empty, wantedFlatCache = Map.empty }
+
+newtype FunEqHead = FunEqHead (TyCon,[Xi])
+
+instance Eq FunEqHead where
+  FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2
+
+instance Ord FunEqHead where
+  FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2) 
+    = case compare tc1 tc2 of 
+        EQ    -> cmpTypes xis1 xis2
+        other -> other
+
 type TcsUntouchables = (Untouchables,TcTyVarSet)
 -- Like the TcM Untouchables, 
 -- but records extra TcsTv variables generated during simplification
@@ -513,12 +553,14 @@ runTcS context untouch tcs
   = do { ty_binds_var <- TcM.newTcRef emptyVarEnv
        ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
        ; step_count <- TcM.newTcRef 0
+       ; flat_cache_var <- TcM.newTcRef emptyFlatCache
        ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
                           , tcs_ty_binds = ty_binds_var
                           , tcs_context  = context
                           , tcs_untch    = (untouch, emptyVarSet) -- No Tcs untouchables yet
 			  , tcs_count    = step_count
 			  , tcs_ic_depth = 0
+                          , tcs_flat_map = flat_cache_var
                           }
 
 	     -- Run the computation
@@ -545,21 +587,31 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside)
     	    	   , tcs_untch = (_outer_range, outer_tcs)
 		   , tcs_count = count
 		   , tcs_ic_depth = idepth
-                   , tcs_context = ctxt } ->
-    let 
-       inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
+                   , tcs_context = ctxt 
+                   , tcs_flat_map = orig_flat_cache_var
+                   } ->
+    do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs)
        		   -- The inner_range should be narrower than the outer one
 		   -- (thus increasing the set of untouchables) but 
 		   -- the inner Tcs-untouchables must be unioned with the
 		   -- outer ones!
-       nest_env = TcSEnv { tcs_ev_binds = ref
-                         , tcs_ty_binds = ty_binds
-                         , tcs_untch    = inner_untch
-                         , tcs_count    = count
-                         , tcs_ic_depth = idepth+1
-                         , tcs_context  = ctxtUnderImplic ctxt }
-    in 
-    thing_inside nest_env
+
+       ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var
+       ; flat_cache_var  <- TcM.newTcRef orig_flat_cache
+       -- One could be more conservative as well: 
+       -- ; flat_cache_var  <- TcM.newTcRef emptyFlatCache 
+
+                            -- Consider copying the results the tcs_flat_map of the 
+                            -- incomping constraint, but we must make sure that we
+                            -- have pushed everything in, which seems somewhat fragile
+       ; let nest_env = TcSEnv { tcs_ev_binds = ref
+                               , tcs_ty_binds = ty_binds
+                               , tcs_untch    = inner_untch
+                               , tcs_count    = count
+                               , tcs_ic_depth = idepth+1
+                               , tcs_context  = ctxtUnderImplic ctxt 
+                               , tcs_flat_map = flat_cache_var }
+       ; thing_inside nest_env }
 
 recoverTcS :: TcS a -> TcS a -> TcS a
 recoverTcS (TcS recovery_code) (TcS thing_inside)
@@ -573,14 +625,16 @@ ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule")
 ctxtUnderImplic ctxt              = ctxt
 
 tryTcS :: TcS a -> TcS a
--- Like runTcS, but from within the TcS monad 
+-- Like runTcS, but from within the TcS monad
 -- Ignore all the evidence generated, and do not affect caller's evidence!
-tryTcS tcs 
+tryTcS tcs
   = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv
                     ; ev_binds_var <- TcM.newTcEvBinds
+                    ; flat_cache_var <- TcM.newTcRef emptyFlatCache
                     ; let env1 = env { tcs_ev_binds = ev_binds_var
-                                     , tcs_ty_binds = ty_binds_var }
-                    ; unTcS tcs env1 })
+                                     , tcs_ty_binds = ty_binds_var
+                                     , tcs_flat_map = flat_cache_var }
+                   ; unTcS tcs env1 })
 
 -- Update TcEvBinds 
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -603,12 +657,51 @@ getTcSTyBinds = TcS (return . tcs_ty_binds)
 getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType))
 getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) 
 
+getFlatCacheMapVar :: TcS (IORef FlatCache)
+getFlatCacheMapVar
+  = TcS (return . tcs_flat_map)
+
+lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor 
+                   -> TcS (Maybe (TcType,Coercion,CtFlavor))
+-- For givens, we lookup in given flat cache
+lookupFlatCacheMap tc xis (Given {})
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) }
+-- For wanteds, we first lookup in givenFlatCache.
+-- If we get nothing back then we lookup in wantedFlatCache.
+lookupFlatCacheMap tc xis (Wanted {})
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of
+           Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map)
+           other   -> return other }
+lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing
+
+updateFlatCacheMap :: TyCon -> [Xi]
+                   -> TcType -> CtFlavor -> Coercion -> TcS ()
+updateFlatCacheMap _tc _xis _tv (Derived {}) _co
+  = return () -- Not caching deriveds
+updateFlatCacheMap tc xis ty fl co
+  = do { cache_ref <- getFlatCacheMapVar
+       ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref
+       ; let new_cache_map
+              | isGivenOrSolved fl
+              = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+                                             givenFlatCache cache_map }
+              | isWanted fl
+              = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $
+                                              wantedFlatCache cache_map }
+              | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty
+       ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map }
+
 
 getTcEvBindsBag :: TcS EvBindMap
 getTcEvBindsBag
   = do { EvBindsVar ev_ref _ <- getTcEvBinds 
        ; wrapTcS $ TcM.readTcRef ev_ref }
 
+
 setCoBind :: CoVar -> Coercion -> TcS () 
 setCoBind cv co = setEvBind cv (EvCoercion co)
 
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 57ff63649a..bed09325ac 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -749,22 +749,26 @@ solve_wanteds inert wanted@(WC { wc_flat = flats, wc_impl = implics, wc_insol =
                                   unsolved_implics
            }
 
-givensFromWanteds :: CanonicalCts -> Bag FlavoredEvVar
--- Extract the *wanted* ones from CanonicalCts
--- and make them into *givens*
-givensFromWanteds = foldrBag getWanted emptyBag
+givensFromWanteds :: SimplContext -> CanonicalCts -> Bag FlavoredEvVar
+-- Extract the Wanted ones from CanonicalCts and conver to
+-- Givens; not Given/Solved, see Note [Preparing inert set for implications]
+givensFromWanteds _ctxt = foldrBag getWanted emptyBag
   where
     getWanted :: CanonicalCt -> Bag FlavoredEvVar -> Bag FlavoredEvVar
     getWanted cc givens
-      | not (isCFrozenErr cc)
-      , Wanted loc <- cc_flavor cc 
-      , let given = mkEvVarX (cc_id cc) (Given (setCtLocOrigin loc UnkSkol))
-      = given `consBag` givens
-      | otherwise 
-      = givens   -- We are not helping anyone by pushing a Derived in!
-                 -- Because if we could not solve it to start with 
-                 -- we are not going to do either inside the impl constraint
-  
+      | pushable_wanted cc
+      = let given = mkEvVarX (cc_id cc) (mkGivenFlavor (cc_flavor cc) UnkSkol)
+        in given `consBag` givens     -- and not mkSolvedFlavor,
+                                      -- see Note [Preparing inert set for implications]
+      | otherwise = givens
+
+    pushable_wanted :: CanonicalCt -> Bool 
+    pushable_wanted cc 
+      | not (isCFrozenErr cc) 
+      , isWantedCt cc 
+      = isEqPred (evVarPred (cc_id cc)) -- see Note [Preparing inert set for implications]
+      | otherwise = False 
+ 
 solveNestedImplications :: InertSet -> CanonicalCts
                         -> Bag Implication
                         -> TcS (Bag FlavoredEvVar, Bag Implication)
@@ -774,15 +778,18 @@ solveNestedImplications just_given_inert unsolved_cans implics
   | otherwise 
   = do {  -- See Note [Preparing inert set for implications]
 	  -- Push the unsolved wanteds inwards, but as givens
-         let pushed_givens    = givensFromWanteds unsolved_cans
+             
+       ; simpl_ctx <- getTcSContext 
+
+       ; let pushed_givens    = givensFromWanteds simpl_ctx unsolved_cans
              tcs_untouchables = filterVarSet isFlexiTcsTv $
                                 tyVarsOfEvVarXs pushed_givens
              -- See Note [Extra TcsTv untouchables]
 
        ; traceTcS "solveWanteds: preparing inerts for implications {"  
                   (vcat [ppr tcs_untouchables, ppr pushed_givens])
-     
-       ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens
+
+       ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens 
 
        ; traceTcS "solveWanteds: } now doing nested implications {" $
          vcat [ text "inerts_for_implics =" <+> ppr inert_for_implics
@@ -933,6 +940,42 @@ We were not able to solve (a ~w [beta]) but we can't just assume it as
 given because the resulting set is not inert. Hence we have to do a
 'solveInteract' step first. 
 
+Finally, note that we convert them to [Given] and NOT [Given/Solved].
+The reason is that Given/Solved are weaker than Givens and may be discarded.
+As an example consider the inference case, where we may have, the following 
+original constraints: 
+     [Wanted] F Int ~ Int
+             (F Int ~ a => F Int ~ a)
+If we convert F Int ~ Int to [Given/Solved] instead of Given, then the next 
+given (F Int ~ a) is going to cause the Given/Solved to be ignored, casting 
+the (F Int ~ a) insoluble. Hence we should really convert the residual 
+wanteds to plain old Given. 
+
+We need only push in unsolved equalities both in checking mode and inference mode: 
+
+  (1) In checking mode we should not push given dictionaries in because of
+example LongWayOverlapping.hs, where we might get strange overlap
+errors between far-away constraints in the program.  But even in
+checking mode, we must still push type family equations. Consider:
+
+   type instance F True a b = a 
+   type instance F False a b = b
+
+   [w] F c a b ~ gamma 
+   (c ~ True) => a ~ gamma 
+   (c ~ False) => b ~ gamma
+
+Since solveCTyFunEqs happens at the very end of solving, the only way to solve
+the two implications is temporarily consider (F c a b ~ gamma) as Given (NB: not 
+merely Given/Solved because it has to interact with the top-level instance 
+environment) and push it inside the implications. Now, when we come out again at
+the end, having solved the implications solveCTyFunEqs will solve this equality.
+
+  (2) In inference mode, we recheck the final constraint in checking mode and
+hence we will be able to solve inner implications from top-level quantified
+constraints nonetheless.
+
+
 Note [Extra TcsTv untouchables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Furthemore, we record the inert set simplifier-generated unification
@@ -1032,7 +1075,7 @@ getSolvableCTyFunEqs untch cts
 
       , not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis))
            -- Occurs check: see Note [Solving Family Equations], Point 2
-      = ASSERT ( not (isGiven fl) )
+      = ASSERT ( not (isGivenOrSolved fl) )
         (cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis))
 
     dflt_funeq (cts_in, fun_eq_binds) ct
diff --git a/docs/users_guide/shared_libs.xml b/docs/users_guide/shared_libs.xml
index 89b656a49f..29dcb37f7f 100644
--- a/docs/users_guide/shared_libs.xml
+++ b/docs/users_guide/shared_libs.xml
@@ -24,12 +24,10 @@
   </para>
 
   <para>
-    In GHC version 6.12 building shared libraries is supported for Linux on
-    x86 and x86-64 architectures and there is partial support on Windows (see
-    <xref linkend="win32-dlls"/>). The crucial difference in support on
-    Windows is that it is not currently possible to build each Haskell
-    package as a separate DLL, it is only possible to link an entire Haskell
-    program as one massive DLL.
+    In GHC version 6.12 building shared libraries is supported for Linux (on
+    x86 and x86-64 architectures). GHC version 7.0 adds support on Windows
+    (see <xref linkend="win32-dlls"/>), FreeBSD and OpenBSD (x86 and x86-64),
+    Solaris (x86) and Mac OS X (x86 and PowerPC).
   </para>
 
   <para>
@@ -59,7 +57,7 @@ ghc --make -dynamic Main.hs
       that it can be linked against shared library versions of Haskell
       packages (such as base). The second is when linking, to link against
       the shared versions of the packages' libraries rather than the static
-      versions. Obviously this requires that the packages were build with
+      versions. Obviously this requires that the packages were built with
       shared libraries. On supported platforms GHC comes with shared
       libraries for all the core packages, but if you install extra packages
       (e.g. with Cabal) then they would also have to be built with shared
@@ -87,10 +85,7 @@ ghc --make -dynamic Main.hs
       In particular Haskell shared libraries <emphasis>must</emphasis> be
       made into packages. You cannot freely assign which modules go in which
       shared libraries. The Haskell shared libraries must match the package
-      boundaries. Most of the conventions GHC expects when using packages are
-      described in <xref linkend="building-packages"/>.
-    </para>
-    <para>
+      boundaries. The reason for this is that
       GHC handles references to symbols <emphasis>within</emphasis> the same
       shared library (or main executable binary) differently from references
       to symbols <emphasis>between</emphasis> different shared libraries. GHC
@@ -153,8 +148,6 @@ ghc -dynamic -shared Foo.o -o libfoo.so
       <literal>-dynamic</literal> in the link step. That means to
       statically link the rts all the base libraries into your new shared
       library. This would make a very big, but standalone shared library.
-      Indeed this is exactly what we must currently do on Windows where
-      -dynamic is not yet supported (see <xref linkend="win32-dlls"/>).
       On most platforms however that would require all the static libraries
       to have been built with <literal>-fPIC</literal> so that the code is
       suitable to include into a shared library and we do not do that at the
@@ -176,6 +169,8 @@ ghc -dynamic -shared Foo.o -o libfoo.so
       The details of how this works varies between platforms, in particular
       the three major systems: Unix ELF platforms, Windows and Mac OS X.
     </para>
+    <sect3 id="finding-shared-libs-unix">
+    <title>Unix</title>
     <para>
       On Unix there are two mechanisms. Shared libraries can be installed
       into standard locations that the dynamic linker knows about. For
@@ -190,20 +185,21 @@ ghc -dynamic -shared Foo.o -o libfoo.so
     <para>
       GHC has a <literal>-dynload</literal> linking flag to select the method
       that is used to find shared libraries at runtime. There are currently
-      three modes:
+      two modes:
       <variablelist>
 	<varlistentry>
 	  <term>sysdep</term>
 	  <listitem>
 	    <para>
 	      A system-dependent mode. This is also the default mode. On Unix
-	      ELF systems this embeds rpaths into the shared library or
-	      executable. In particular it uses absolute paths to where the
-	      shared libraries for the rts and each package can be found.
-	      This means the program can immediately be run and it will be
-	      able to find the libraries it needs. However it may not be
-	      suitable for deployment if the libraries are installed in a
-	      different location on another machine.
+	      ELF systems this embeds
+        <literal>RPATH</literal>/<literal>RUNPATH</literal> entries into the
+        shared library or executable. In particular it uses absolute paths to
+        where the shared libraries for the rts and each package can be found.
+	      This means the program can immediately be run and it will be able to
+        find the libraries it needs. However it may not be suitable for
+        deployment if the libraries are installed in a different location on
+        another machine.
 	    </para>
 	  </listitem>
 	</varlistentry>
@@ -220,8 +216,7 @@ ghc -dynamic -shared Foo.o -o libfoo.so
 	</varlistentry>
       </variablelist>
       To use relative paths for dependent libraries on Linux and Solaris you
-      can use the <literal>deploy</literal> mode and pass suitable a -rpath
-      flag to the linker:
+      can pass a suitable <literal>-rpath</literal> flag to the linker:
 <programlisting>
 ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
 </programlisting>
@@ -232,7 +227,24 @@ ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
       executable e.g. <literal>-optl-Wl,-rpath,'$ORIGIN/lib'</literal>.
     </para>
     <para>
-      The standard assumption on Darwin/MacOS X is that dynamic libraries will
+      This relative path technique can be used with either of the two
+      <literal>-dynload</literal> modes, though it makes most sense with the
+      <literal>deploy</literal> mode. The difference is that with the
+      <literal>deploy</literal> mode, the above example will end up with an ELF
+      <literal>RUNPATH</literal> of just <literal>$ORIGIN</literal> while with
+      the <literal>sysdep</literal> mode the <literal>RUNPATH</literal> will be
+      <literal>$ORIGIN</literal> followed by all the library directories of all
+      the packages that the program depends on (e.g. <literal>base</literal>
+      and <literal>rts</literal> packages etc.) which are typically absolute
+      paths. The unix tool <literal>readelf --dynamic</literal> is handy for
+      inspecting the <literal>RPATH</literal>/<literal>RUNPATH</literal>
+      entries in ELF shared libraries and executables.
+    </para>
+    </sect3>
+    <sect3 id="finding-shared-libs-mac">
+    <title>Mac OS X</title>
+    <para>
+      The standard assumption on Darwin/Mac OS X is that dynamic libraries will
       be stamped at build time with an "install name", which is the full
       ultimate install path of the library file. Any libraries or executables
       that subsequently link against it (even if it hasn't been installed yet)
@@ -244,6 +256,7 @@ ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN'
       for you. It automatically sets the install name for dynamic libraries to
       the absolute path of the ultimate install location.
     </para>
+    </sect3>
   </sect2>
 
 </sect1>
diff --git a/docs/users_guide/win32-dlls.xml b/docs/users_guide/win32-dlls.xml
index f00e1e2c38..44f589adf2 100644
--- a/docs/users_guide/win32-dlls.xml
+++ b/docs/users_guide/win32-dlls.xml
@@ -209,15 +209,6 @@ make-sessions running under cygwin.
 </title>
 
 <para>
-<emphasis>Making Haskell libraries into DLLs doesn't work on Windows at the
-moment; we hope to re-instate this facility in the future
-(see <xref linkend="using-shared-libs"/>).  Note that
-building an entire Haskell application as a single DLL is still supported: it's
-	just multi-DLL Haskell programs that don't work.  The Windows
-	distribution of GHC contains static libraries only.</emphasis></para>
-
-<!--
-<para>
 <indexterm><primary>Dynamic link libraries, Win32</primary></indexterm>
 <indexterm><primary>DLLs, Win32</primary></indexterm>
 On Win32 platforms, the compiler is capable of both producing and using
@@ -226,6 +217,33 @@ section shows you how to make use of this facility.
 </para>
 
 <para>
+There are two distinct ways in which DLLs can be used:
+<itemizedlist>
+  <listitem>
+    <para>
+      You can turn each Haskell package into a DLL, so that multiple
+      Haskell executables using the same packages can share the DLL files.
+      (As opposed to linking the libraries statically, which in effect
+      creates a new copy of the RTS and all libraries for each executable
+      produced.)
+    </para>
+    <para>
+      That is the same as the dynamic linking on other platforms, and it
+      is described in <xref linkend="using-shared-libs"/>.
+    </para>
+  </listitem>
+  <listitem>
+    <para>
+      You can package up a complete Haskell program as a DLL, to be called
+      by some external (usually non-Haskell) program. This is usually used
+      to implement plugins and the like, and is described below.
+    </para>
+  </listitem>
+</itemizedlist>
+</para>
+
+<!--
+<para>
 Until recently, <command>strip</command> didn't work reliably on DLLs, so you
 should test your version with care, or make sure you have the latest
 binutils. Unfortunately, we don't know exactly which version of binutils
diff --git a/includes/Cmm.h b/includes/Cmm.h
index 0ba14fbff6..641faa216e 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -464,8 +464,10 @@
 #define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraFwd_bitmap(i)
 #endif
 
-#define mutArrPtrsCardWords(n) \
-    ROUNDUP_BYTES_TO_WDS(((n) + (1 << MUT_ARR_PTRS_CARD_BITS) - 1) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrCardUp(i)   (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))
 
 #if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
 #define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h
index f3f56c9dd0..16f1c8b545 100644
--- a/includes/rts/EventLogFormat.h
+++ b/includes/rts/EventLogFormat.h
@@ -112,6 +112,7 @@
 #define EVENT_GC_END              10 /* ()                     */
 #define EVENT_REQUEST_SEQ_GC      11 /* ()                     */
 #define EVENT_REQUEST_PAR_GC      12 /* ()                     */
+/* 13, 14 deprecated */
 #define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread)         */
 #define EVENT_LOG_MSG             16 /* (message ...)          */
 #define EVENT_STARTUP             17 /* (num_capabilities)     */
@@ -120,12 +121,39 @@
 #define EVENT_GC_IDLE             20 /* () */
 #define EVENT_GC_WORK             21 /* () */
 #define EVENT_GC_DONE             22 /* () */
+/* 23, 24 used by eden */
+#define EVENT_CAPSET_CREATE       25 /* (capset, capset_type)  */
+#define EVENT_CAPSET_DELETE       26 /* (capset)               */
+#define EVENT_CAPSET_ASSIGN_CAP   27 /* (capset, cap)          */
+#define EVENT_CAPSET_REMOVE_CAP   28 /* (capset, cap)          */
+/* the RTS identifier is in the form of "GHC-version rts_way"  */
+#define EVENT_RTS_IDENTIFIER      29 /* (capset, name_version_string) */
+/* the vectors in these events are null separated strings             */
+#define EVENT_PROGRAM_ARGS        30 /* (capset, commandline_vector)  */
+#define EVENT_PROGRAM_ENV         31 /* (capset, environment_vector)  */
+#define EVENT_OSPROCESS_PID       32 /* (capset, pid, parent_pid)     */
 
-#define NUM_EVENT_TAGS            23
+
+/* Range 33 - 59 is available for new events */
+
+/* Range 60 - 80 is used by eden for parallel tracing
+ * see http://www.mathematik.uni-marburg.de/~eden/
+ */
+
+/*
+ * The highest event code +1 that ghc itself emits. Note that some event
+ * ranges higher than this are reserved but not currently emitted by ghc.
+ * This must match the size of the EventDesc[] array in EventLog.c
+ */
+#define NUM_EVENT_TAGS            33
 
 #if 0  /* DEPRECATED EVENTS: */
+/* ghc changed how it handles sparks so these are no longer applicable */
 #define EVENT_CREATE_SPARK        13 /* (cap, thread) */
 #define EVENT_SPARK_TO_THREAD     14 /* (cap, thread, spark_thread) */
+/* these are used by eden but are replaced by new alternatives for ghc */
+#define EVENT_VERSION             23 /* (version_string) */
+#define EVENT_PROGRAM_INVOCATION  24 /* (commandline_string) */
 #endif
 
 /*
@@ -152,6 +180,13 @@
  */
 #define THREAD_SUSPENDED_FOREIGN_CALL 6
 
+/*
+ * Capset type values for EVENT_CAPSET_CREATE
+ */
+#define CAPSET_TYPE_CUSTOM      1  /* reserved for end-user applications */
+#define CAPSET_TYPE_OSPROCESS   2  /* caps belong to the same OS process */
+#define CAPSET_TYPE_CLOCKDOMAIN 3  /* caps share a local clock/time      */
+
 #ifndef EVENTLOG_CONSTANTS_ONLY
 
 typedef StgWord16 EventTypeNum;
@@ -160,6 +195,8 @@ typedef StgWord32 EventThreadID;
 typedef StgWord16 EventCapNo;
 typedef StgWord16 EventPayloadSize; /* variable-size events */
 typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */
+typedef StgWord32 EventCapsetID;
+typedef StgWord16 EventCapsetType;   /* types for EVENT_CAPSET_CREATE */
 
 #endif
 
diff --git a/rts/Capability.c b/rts/Capability.c
index 9091fdde0c..9557fcc07f 100644
--- a/rts/Capability.c
+++ b/rts/Capability.c
@@ -253,6 +253,8 @@ initCapability( Capability *cap, nat i )
     cap->transaction_tokens = 0;
     cap->context_switch = 0;
     cap->pinned_object_block = NULL;
+
+    traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i);
 }
 
 /* ---------------------------------------------------------------------------
@@ -266,6 +268,7 @@ initCapability( Capability *cap, nat i )
 void
 initCapabilities( void )
 {
+
 #if defined(THREADED_RTS)
     nat i;
 
@@ -833,6 +836,7 @@ freeCapabilities (void)
 #else
     freeCapability(&MainCapability);
 #endif
+    traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
 }
 
 /* ---------------------------------------------------------------------------
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 5c9cfb75ad..e17c6fb3f8 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -212,6 +212,7 @@ stg_unsafeThawArrayzh
   }
 }
 
+
 /* -----------------------------------------------------------------------------
    MutVar primitives
    -------------------------------------------------------------------------- */
diff --git a/rts/RtsProbes.d b/rts/RtsProbes.d
index dbc5111e46..bd32fca385 100644
--- a/rts/RtsProbes.d
+++ b/rts/RtsProbes.d
@@ -23,6 +23,8 @@
  * typedef uint16_t EventCapNo;
  * typedef uint16_t EventPayloadSize; // variable-size events
  * typedef uint16_t EventThreadStatus;
+ * typedef uint32_t EventCapsetID;
+ * typedef uint16_t EventCapsetType;  // types for EVENT_CAPSET_CREATE
  */
 
 /* -----------------------------------------------------------------------------
@@ -60,5 +62,9 @@ provider HaskellEvent {
   probe gc__idle (EventCapNo);
   probe gc__work (EventCapNo);
   probe gc__done (EventCapNo);
+  probe capset__create(EventCapsetID, EventCapsetType);
+  probe capset__delete(EventCapsetID);
+  probe capset__assign__cap(EventCapsetID, EventCapNo);
+  probe capset__remove__cap(EventCapsetID, EventCapNo);
 
 };
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 236d07a9e0..502906ebed 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -148,6 +148,10 @@ hs_init(int *argc, char **argv[])
      */
     dtraceEventStartup();
 
+    /* Trace some basic information about the process
+     */
+    traceCapsetDetails(argc, argv);
+
     /* initialise scheduler data structures (needs to be done before
      * initStorage()).
      */
diff --git a/rts/Schedule.c b/rts/Schedule.c
index 9636223836..9b151d7283 100644
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -2030,16 +2030,16 @@ exitScheduler (rtsBool wait_foreign USED_IF_THREADS)
     }
     sched_state = SCHED_SHUTTING_DOWN;
 
+    nat i;
+
+    for (i = 0; i < n_capabilities; i++) {
 #if defined(THREADED_RTS)
-    { 
-	nat i;
-	
-	for (i = 0; i < n_capabilities; i++) {
-            ASSERT(task->incall->tso == NULL);
-	    shutdownCapability(&capabilities[i], task, wait_foreign);
-	}
-    }
+        ASSERT(task->incall->tso == NULL);
+        shutdownCapability(&capabilities[i], task, wait_foreign);
 #endif
+        traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, i);
+    }
+    traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT);
 
     boundTaskExiting(task);
 }
diff --git a/rts/Trace.c b/rts/Trace.c
index f2f9e81549..fb8e9226af 100644
--- a/rts/Trace.c
+++ b/rts/Trace.c
@@ -20,6 +20,10 @@
 #include "Threads.h"
 #include "Printer.h"
 
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
 #ifdef DEBUG
 // debugging flags, set with +RTS -D<something>
 int DEBUG_sched;
@@ -251,6 +255,69 @@ void traceSchedEvent_ (Capability *cap, EventTypeNum tag,
     }
 }
 
+void traceCapsetModify_ (EventTypeNum tag,
+                         CapsetID capset,
+                         StgWord32 other,
+                         StgWord32 other2)
+{
+#ifdef DEBUG
+    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
+        ACQUIRE_LOCK(&trace_utx);
+
+        tracePreface();
+        switch (tag) {
+        case EVENT_CAPSET_CREATE:   // (capset, capset_type)
+            debugBelch("created capset %d of type %d\n", capset, other);
+            break;
+        case EVENT_CAPSET_DELETE:   // (capset)
+            debugBelch("deleted capset %d\n", capset);
+            break;
+        case EVENT_CAPSET_ASSIGN_CAP:  // (capset, capno)
+            debugBelch("assigned cap %d to capset %d\n", other, capset);
+            break;
+        case EVENT_CAPSET_REMOVE_CAP:  // (capset, capno)
+            debugBelch("removed cap %d from capset %d\n", other, capset);
+            break;
+        }
+        RELEASE_LOCK(&trace_utx);
+    } else
+#endif
+    {
+        if(eventlog_enabled) postCapsetModifyEvent(tag, capset, other, other2);
+    }
+}
+
+extern char **environ;
+
+void traceCapsetDetails_(int *argc, char **argv[]){
+    if(eventlog_enabled){
+        postCapsetModifyEvent(EVENT_OSPROCESS_PID,
+                              CAPSET_OSPROCESS_DEFAULT,
+                              getpid(),
+                              getppid());
+
+        char buf[256];
+        snprintf(buf, sizeof(buf), "GHC-%s %s", ProjectVersion, RtsWay);
+        postCapsetStrEvent(EVENT_RTS_IDENTIFIER,
+                           CAPSET_OSPROCESS_DEFAULT,
+                           buf);
+
+        if(argc != NULL && argv != NULL){
+            postCapsetVecEvent(EVENT_PROGRAM_ARGS,
+                               CAPSET_OSPROCESS_DEFAULT,
+                               *argc,
+                               *argv);
+        }
+
+        int env_len;
+        for( env_len = 0; environ[env_len] != NULL; env_len++);
+        postCapsetVecEvent(EVENT_PROGRAM_ENV,
+                           CAPSET_OSPROCESS_DEFAULT,
+                           env_len,
+                           environ);
+    }
+}
+
 void traceEvent_ (Capability *cap, EventTypeNum tag)
 {
 #ifdef DEBUG
diff --git a/rts/Trace.h b/rts/Trace.h
index 620915665b..04075ad6e9 100644
--- a/rts/Trace.h
+++ b/rts/Trace.h
@@ -31,6 +31,13 @@ void resetTracing (void);
 
 #endif /* TRACING */
 
+typedef StgWord32 CapsetID;
+typedef StgWord16 CapsetType;
+enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM,
+                  CapsetTypeOsProcess = CAPSET_TYPE_OSPROCESS,
+                  CapsetTypeClockdomain = CAPSET_TYPE_CLOCKDOMAIN };
+#define CAPSET_OSPROCESS_DEFAULT 0
+
 // -----------------------------------------------------------------------------
 // Message classes
 // -----------------------------------------------------------------------------
@@ -160,6 +167,21 @@ void traceUserMsg(Capability *cap, char *msg);
 
 void traceThreadStatus_ (StgTSO *tso);
 
+/*
+ * Events for describing capability sets in the eventlog
+ *
+ * Note: unlike other events, these are not conditional on TRACE_sched or
+ * similar because they are not "real" events themselves but provide
+ * information and context for other "real" events. Other events depend on
+ * the capset info events so for simplicity, rather than working out if
+ * they're necessary we always emit them. They should be very low volume.
+ */
+void traceCapsetModify_ (EventTypeNum tag,
+                         CapsetID capset,
+                         StgWord32 other,
+                         StgWord32 other2);
+
+void traceCapsetDetails_ (int *argc, char **argv[]);
 #else /* !TRACING */
 
 #define traceSchedEvent(cap, tag, tso, other) /* nothing */
@@ -170,6 +192,8 @@ void traceThreadStatus_ (StgTSO *tso);
 #define debugTrace(class, str, ...) /* nothing */
 #define debugTraceCap(class, cap, str, ...) /* nothing */
 #define traceThreadStatus(class, tso) /* nothing */
+#define traceCapsetModify_(tag, capset, other, other2) /* nothing */
+#define traceCapsetDetails_(argc, argv) /* nothing */
 
 #endif /* TRACING */
 
@@ -226,6 +250,14 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
     HASKELLEVENT_GC_WORK(cap)
 #define dtraceGcDone(cap)                               \
     HASKELLEVENT_GC_DONE(cap)
+#define dtraceCapsetCreate(capset, capset_type)         \
+    HASKELLEVENT_CAPSET_CREATE(capset, capset_type)
+#define dtraceCapsetDelete(capset)                      \
+    HASKELLEVENT_CAPSET_DELETE(capset)
+#define dtraceCapsetAssignCap(capset, capno)            \
+    HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno)
+#define dtraceCapsetRemoveCap(capset, capno)            \
+    HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno)
 
 #else /* !defined(DTRACE) */
 
@@ -248,6 +280,10 @@ void dtraceUserMsgWrapper(Capability *cap, char *msg);
 #define dtraceGcIdle(cap)                               /* nothing */
 #define dtraceGcWork(cap)                               /* nothing */
 #define dtraceGcDone(cap)                               /* nothing */
+#define dtraceCapsetCreate(capset, capset_type)         /* nothing */
+#define dtraceCapsetDelete(capset)                      /* nothing */
+#define dtraceCapsetAssignCap(capset, capno)            /* nothing */
+#define dtraceCapsetRemoveCap(capset, capno)            /* nothing */
 
 #endif
 
@@ -405,6 +441,39 @@ INLINE_HEADER void traceEventGcDone(Capability *cap STG_UNUSED)
     dtraceGcDone((EventCapNo)cap->no);
 }
 
+INLINE_HEADER void traceCapsetCreate(CapsetID   capset      STG_UNUSED,
+                                     CapsetType capset_type STG_UNUSED)
+{
+    traceCapsetModify_(EVENT_CAPSET_CREATE, capset, capset_type, 0);
+    dtraceCapsetCreate(capset, capset_type);
+}
+
+INLINE_HEADER void traceCapsetDelete(CapsetID capset STG_UNUSED)
+{
+    traceCapsetModify_(EVENT_CAPSET_DELETE, capset, 0, 0);
+    dtraceCapsetDelete(capset);
+}
+
+INLINE_HEADER void traceCapsetAssignCap(CapsetID capset STG_UNUSED,
+                                        nat      capno  STG_UNUSED)
+{
+    traceCapsetModify_(EVENT_CAPSET_ASSIGN_CAP, capset, capno, 0);
+    dtraceCapsetAssignCap(capset, capno);
+}
+
+INLINE_HEADER void traceCapsetRemoveCap(CapsetID capset STG_UNUSED,
+                                        nat      capno  STG_UNUSED)
+{
+    traceCapsetModify_(EVENT_CAPSET_REMOVE_CAP, capset, capno, 0);
+    dtraceCapsetRemoveCap(capset, capno);
+}
+
+INLINE_HEADER void traceCapsetDetails(int *argc STG_UNUSED, char **argv[] STG_UNUSED)
+{
+    traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess);
+    traceCapsetDetails_(argc, argv);
+}
+
 #include "EndPrivate.h"
 
 #endif /* TRACE_H */
diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c
index a77c257e1b..d2e3de35ff 100644
--- a/rts/eventlog/EventLog.c
+++ b/rts/eventlog/EventLog.c
@@ -75,7 +75,15 @@ char *EventDesc[] = {
   [EVENT_GC_IDLE]             = "GC idle",
   [EVENT_GC_WORK]             = "GC working",
   [EVENT_GC_DONE]             = "GC done",
-  [EVENT_BLOCK_MARKER]        = "Block marker"
+  [EVENT_BLOCK_MARKER]        = "Block marker",
+  [EVENT_CAPSET_CREATE]       = "Create capability set",
+  [EVENT_CAPSET_DELETE]       = "Delete capability set",
+  [EVENT_CAPSET_ASSIGN_CAP]   = "Add capability to capability set",
+  [EVENT_CAPSET_REMOVE_CAP]   = "Remove capability from capability set",
+  [EVENT_RTS_IDENTIFIER]      = "Identify the RTS version",
+  [EVENT_PROGRAM_ARGS]        = "Identify the program arguments",
+  [EVENT_PROGRAM_ENV]         = "Identify the environment variables",
+  [EVENT_OSPROCESS_PID]       = "Identify the process ID of a capability set"
 };
 
 // Event type. 
@@ -146,6 +154,12 @@ static inline void postThreadID(EventsBuf *eb, EventThreadID id)
 static inline void postCapNo(EventsBuf *eb, EventCapNo no)
 { postWord16(eb,no); }
 
+static inline void postCapsetID(EventsBuf *eb, EventCapsetID id)
+{ postWord32(eb,id); }
+
+static inline void postCapsetType(EventsBuf *eb, EventCapsetType type)
+{ postWord16(eb,type); }
+
 static inline void postPayloadSize(EventsBuf *eb, EventPayloadSize size)
 { postWord16(eb,size); }
 
@@ -259,6 +273,26 @@ initEventLogging(void)
             eventTypes[t].size = sizeof(EventCapNo);
             break;
 
+        case EVENT_CAPSET_CREATE:   // (capset, capset_type)
+            eventTypes[t].size =
+                sizeof(EventCapsetID) + sizeof(EventCapsetType);
+            break;
+
+        case EVENT_CAPSET_DELETE:   // (capset)
+            eventTypes[t].size = sizeof(EventCapsetID);
+            break;
+
+        case EVENT_CAPSET_ASSIGN_CAP:  // (capset, cap)
+        case EVENT_CAPSET_REMOVE_CAP:
+            eventTypes[t].size =
+                sizeof(EventCapsetID) + sizeof(EventCapNo);
+            break;
+
+        case EVENT_OSPROCESS_PID: // (cap, pid, parent pid)
+            eventTypes[t].size =
+                sizeof(EventCapsetID) + 2*sizeof(StgWord32);
+            break;
+
         case EVENT_SHUTDOWN:        // (cap)
         case EVENT_REQUEST_SEQ_GC:  // (cap)
         case EVENT_REQUEST_PAR_GC:  // (cap)
@@ -272,6 +306,9 @@ initEventLogging(void)
 
         case EVENT_LOG_MSG:          // (msg)
         case EVENT_USER_MSG:         // (msg)
+        case EVENT_RTS_IDENTIFIER:   // (capset, str)
+        case EVENT_PROGRAM_ARGS:     // (capset, strvec)
+        case EVENT_PROGRAM_ENV:      // (capset, strvec)
             eventTypes[t].size = 0xffff;
             break;
 
@@ -443,6 +480,116 @@ postSchedEvent (Capability *cap,
     }
 }
 
+void postCapsetModifyEvent (EventTypeNum tag,
+                            EventCapsetID capset,
+                            StgWord32 other,
+                            StgWord32 other2)
+{
+    ACQUIRE_LOCK(&eventBufMutex);
+
+    if (!hasRoomForEvent(&eventBuf, tag)) {
+        // Flush event buffer to make room for new event.
+        printAndClearEventBuf(&eventBuf);
+    }
+
+    postEventHeader(&eventBuf, tag);
+    postCapsetID(&eventBuf, capset);
+
+    switch (tag) {
+    case EVENT_CAPSET_CREATE:   // (capset, capset_type)
+    {
+        postCapsetType(&eventBuf, other /* capset_type */);
+        break;
+    }
+
+    case EVENT_CAPSET_DELETE:   // (capset)
+    {
+        break;
+    }
+
+    case EVENT_CAPSET_ASSIGN_CAP:  // (capset, capno)
+    case EVENT_CAPSET_REMOVE_CAP:  // (capset, capno)
+    {
+        postCapNo(&eventBuf, other /* capno */);
+        break;
+    }
+    case EVENT_OSPROCESS_PID:
+    {
+        postWord32(&eventBuf, other);
+        postWord32(&eventBuf, other2);
+        break;
+    }
+    default:
+        barf("postCapsetModifyEvent: unknown event tag %d", tag);
+    }
+
+    RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetStrEvent (EventTypeNum tag,
+                         EventCapsetID capset,
+                         char *msg)
+{
+    int strsize = strlen(msg);
+    int size = strsize + sizeof(EventCapsetID)
+
+    ACQUIRE_LOCK(&eventBufMutex);
+
+    if (!hasRoomForVariableEvent(&eventBuf, size)){
+        printAndClearEventBuf(&eventBuf);
+
+        if (!hasRoomForVariableEvent(&eventBuf, size)){
+            // Event size exceeds buffer size, bail out:
+            RELEASE_LOCK(&eventBufMutex);
+            return;
+        }
+    }
+
+    postEventHeader(&eventBuf, tag);
+    postPayloadSize(&eventBuf, size);
+    postCapsetID(&eventBuf, capset);
+
+    postBuf(&eventBuf, (StgWord8*) msg, strsize);
+
+    RELEASE_LOCK(&eventBufMutex);
+}
+
+void postCapsetVecEvent (EventTypeNum tag,
+                         EventCapsetID capset,
+                         int argc,
+                         char *argv[])
+{
+    int i, size = sizeof(EventCapsetID);
+
+    for (i = 0; i < argc; i++) {
+        // 1 + strlen to account for the trailing \0, used as separator
+        size += 1 + strlen(argv[i]);
+    }
+
+    ACQUIRE_LOCK(&eventBufMutex);
+
+    if (!hasRoomForVariableEvent(&eventBuf, size)){
+        printAndClearEventBuf(&eventBuf);
+
+        if(!hasRoomForVariableEvent(&eventBuf, size)){
+            // Event size exceeds buffer size, bail out:
+            RELEASE_LOCK(&eventBufMutex);
+            return;
+        }
+    }
+
+    postEventHeader(&eventBuf, tag);
+    postPayloadSize(&eventBuf, size);
+    postCapsetID(&eventBuf, capset);
+
+    for( i = 0; i < argc; i++ ) {
+        // again, 1 + to account for \0
+        postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i]));
+    }
+
+    RELEASE_LOCK(&eventBufMutex);
+}
+
 void
 postEvent (Capability *cap, EventTypeNum tag)
 {
diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h
index 0cfab5c091..26a2e944bf 100644
--- a/rts/eventlog/EventLog.h
+++ b/rts/eventlog/EventLog.h
@@ -35,6 +35,29 @@ void postSchedEvent(Capability *cap, EventTypeNum tag,
                     StgThreadID id, StgWord info1, StgWord info2);
 
 /*
+ * Post a capability set modification event
+ */
+void postCapsetModifyEvent (EventTypeNum tag,
+                            EventCapsetID capset,
+                            StgWord32 other,
+                            StgWord32 other2);
+
+/*
+ * Post a capability set event with a string payload
+ */
+void postCapsetStrEvent (EventTypeNum tag,
+                         EventCapsetID capset,
+                         char *msg);
+
+/*
+ * Post a capability set event with several strings payload
+ */
+void postCapsetVecEvent (EventTypeNum tag,
+                         EventCapsetID capset,
+                         int argc,
+                         char *msg[]);
+
+/*
  * Post a nullary event.
  */
 void postEvent(Capability *cap, EventTypeNum tag);
@@ -54,6 +77,12 @@ INLINE_HEADER void postSchedEvent (Capability *cap  STG_UNUSED,
                                    StgWord info2    STG_UNUSED)
 { /* nothing */ }
 
+INLINE_HEADER void postCapsetModifyEvent (EventTypeNum tag     STG_UNUSED,
+                                          EventCapsetID capset STG_UNUSED,
+                                          StgWord32 other      STG_UNUSED,
+                                          StgWord32 other2     STG_UNUSED)
+{ /* nothing */ }
+
 INLINE_HEADER void postEvent (Capability *cap  STG_UNUSED,
                               EventTypeNum tag STG_UNUSED)
 { /* nothing */ }
diff --git a/rts/ghc.mk b/rts/ghc.mk
index a2369452b7..38ddbc0d46 100644
--- a/rts/ghc.mk
+++ b/rts/ghc.mk
@@ -295,6 +295,7 @@ rts/RtsMain_HC_OPTS += -optc-O0
 
 rts/RtsMessages_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
 rts/RtsUtils_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
+rts/Trace_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\"
 #
 rts/RtsUtils_CC_OPTS += -DHostPlatform=\"$(HOSTPLATFORM)\"
 rts/RtsUtils_CC_OPTS += -DHostArch=\"$(HostArch_CPP)\"
diff --git a/sync-all b/sync-all
index 5dc6a40953..8b41c97711 100755
--- a/sync-all
+++ b/sync-all
@@ -366,6 +366,9 @@ sub scmall {
             my @scm_args = ("log", "$branch_name..");
             scm ($localpath, $scm, @scm_args, @args);
         }
+        elsif ($command =~ /^log$/) {
+            scm ($localpath, $scm, "log", @args);
+        }
         elsif ($command =~ /^remote$/) {
             my @scm_args;
             if ($subcommand eq 'add') {
@@ -434,6 +437,7 @@ Supported commands:
  * clean
  * reset
  * config
+ * log
 
 Available package-tags are:
 END