Merge remote-tracking branch 'origin/master' into wip/tc-plugins-amgwip/tc-plugins-amg

47 files changed, 1111 insertions, 547 deletions

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 9fc728b3f6..b32a2b7bfc 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -1146,17 +1146,14 @@ coerceId = pcMiscPrelId coerceName ty info
   where
     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
-    kv = kKiVar
-    k = mkTyVarTy kv
-    a:b:_ = tyVarList k
-    [aTy,bTy] = map mkTyVarTy [a,b]
-    eqRTy     = mkTyConApp coercibleTyCon  [k, aTy, bTy]
-    eqRPrimTy = mkTyConApp eqReprPrimTyCon [k, aTy, bTy]
-    ty   = mkForAllTys [kv, a, b] (mkFunTys [eqRTy, aTy] bTy)
-
-    [eqR,x,eq] = mkTemplateLocals [eqRTy, aTy,eqRPrimTy]
-    rhs = mkLams [kv,a,b,eqR,x] $
-          mkWildCase (Var eqR) eqRTy bTy $
+    eqRTy     = mkTyConApp coercibleTyCon  [liftedTypeKind, alphaTy, betaTy]
+    eqRPrimTy = mkTyConApp eqReprPrimTyCon [liftedTypeKind, alphaTy, betaTy]
+    ty        = mkForAllTys [alphaTyVar, betaTyVar] $
+                mkFunTys [eqRTy, alphaTy] betaTy
+
+    [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy]
+    rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $
+          mkWildCase (Var eqR) eqRTy betaTy $
           [(DataAlt coercibleDataCon, [eq], Cast (Var x) (CoVarCo eq))]
 \end{code}
 
diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index edd2986ed3..57f02d9b2a 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -380,7 +380,12 @@ integerPackageKey, primPackageKey,
   thPackageKey, dphSeqPackageKey, dphParPackageKey,
   mainPackageKey, thisGhcPackageKey, interactivePackageKey  :: PackageKey
 primPackageKey        = fsToPackageKey (fsLit "ghc-prim")
-integerPackageKey     = fsToPackageKey (fsLit cIntegerLibrary)
+integerPackageKey     = fsToPackageKey (fsLit n)
+  where
+    n = case cIntegerLibraryType of
+        IntegerGMP    -> "integer-gmp"
+        IntegerGMP2   -> "integer-gmp"
+        IntegerSimple -> "integer-simple"
 basePackageKey        = fsToPackageKey (fsLit "base")
 rtsPackageKey         = fsToPackageKey (fsLit "rts")
 thPackageKey          = fsToPackageKey (fsLit "template-haskell")
diff --git a/compiler/basicTypes/PatSyn.lhs b/compiler/basicTypes/PatSyn.lhs
index 89c4374388..c651080244 100644
--- a/compiler/basicTypes/PatSyn.lhs
+++ b/compiler/basicTypes/PatSyn.lhs
@@ -14,7 +14,8 @@ module PatSyn (
         -- ** Type deconstruction
         patSynName, patSynArity, patSynIsInfix,
         patSynArgs, patSynTyDetails, patSynType,
-        patSynWrapper, patSynMatcher,
+        patSynMatcher,
+        patSynWrapper, patSynWorker,
         patSynExTyVars, patSynSig,
         patSynInstArgTys, patSynInstResTy,
         tidyPatSynIds
@@ -36,6 +37,7 @@ import HsBinds( HsPatSynDetails(..) )
 import qualified Data.Data as Data
 import qualified Data.Typeable
 import Data.Function
+import Control.Arrow (second)
 \end{code}
 
 
@@ -109,6 +111,37 @@ Injectivity of bidirectional pattern synonyms is checked in
 tcPatToExpr which walks the pattern and returns its corresponding
 expression when available.
 
+Note [Wrapper/worker for pattern synonyms with unboxed type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For bidirectional pattern synonyms that have no arguments and have
+an unboxed type, we add an extra level of indirection, since $WP would
+otherwise be a top-level declaration with an unboxed type. In this case,
+a separate worker function is generated that has an extra Void# argument,
+and the wrapper redirects to it via a compulsory unfolding (that just
+applies it on Void#). Example:
+
+        pattern P = 0#
+
+        $WP :: Int#
+        $WP unfolded to ($wP Void#)
+
+        $wP :: Void# -> Int#
+        $wP _ = 0#
+
+To make things more uniform, we always store two `Id`s in `PatSyn` for
+the wrapper and the worker, with the following behaviour:
+
+  if `psWrapper` == Just (`wrapper`, `worker`), then
+
+  * `wrapper` should always be used when compiling the pattern synonym
+    in an expression context (and its type is as prescribed)
+  * `worker` is always an `Id` with a binding that needs to be exported
+    as part of the definition of the pattern synonym
+
+If a separate worker is not needed (because the pattern synonym has arguments
+or has a non-unboxed type), the two `Id`s are the same.
+
 %************************************************************************
 %*                                                                      *
 \subsection{Pattern synonyms}
@@ -149,12 +182,14 @@ data PatSyn
              --                       -> (Void# -> r)
              --                       -> r
 
-        psWrapper     :: Maybe Id
+        psWrapper     :: Maybe (Id, Id)
              -- Nothing  => uni-directional pattern synonym
-             -- Just wid => bi-direcitonal
+             -- Just (wrapper, worker) => bi-direcitonal
              -- Wrapper function, of type
              --  forall univ_tvs, ex_tvs. (prov_theta, req_theta)
              --                       =>  arg_tys -> res_ty
+             --
+             -- See Note [Wrapper/worker for pattern synonyms with unboxed type]
   }
   deriving Data.Typeable.Typeable
 \end{code}
@@ -215,7 +250,7 @@ mkPatSyn :: Name
          -> [Type]               -- ^ Original arguments
          -> Type                 -- ^ Original result type
          -> Id                   -- ^ Name of matcher
-         -> Maybe Id             -- ^ Name of wrapper
+         -> Maybe (Id, Id)       -- ^ Name of wrapper/worker
          -> PatSyn
 mkPatSyn name declared_infix
          (univ_tvs, req_theta)
@@ -276,14 +311,17 @@ patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
   = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
 
 patSynWrapper :: PatSyn -> Maybe Id
-patSynWrapper = psWrapper
+patSynWrapper = fmap fst . psWrapper
+
+patSynWorker :: PatSyn -> Maybe Id
+patSynWorker = fmap snd . psWrapper
 
 patSynMatcher :: PatSyn -> Id
 patSynMatcher = psMatcher
 
 tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn
 tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = match_id, psWrapper = mb_wrap_id })
-  = ps { psMatcher = tidy_fn match_id, psWrapper = fmap tidy_fn mb_wrap_id }
+  = ps { psMatcher = tidy_fn match_id, psWrapper = fmap (second tidy_fn) mb_wrap_id }
 
 patSynInstArgTys :: PatSyn -> [Type] -> [Type]
 -- Return the types of the argument patterns
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index d4afaf10fc..b9e3fcbd6a 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -157,9 +157,14 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName
 setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
 setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
 setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
-setRdrNameSpace (Exact n)    ns = ASSERT( isExternalName n )
-                                  Orig (nameModule n)
-                                       (setOccNameSpace ns (nameOccName n))
+setRdrNameSpace (Exact n)    ns
+  | isExternalName n
+  = Orig (nameModule n) occ
+  | otherwise   -- This can happen when quoting and then splicing a fixity
+                -- declaration for a type
+  = Exact $ mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)
+  where
+    occ = setOccNameSpace ns (nameOccName n)
 
 -- demoteRdrName lowers the NameSpace of RdrName.
 -- see Note [Demotion] in OccName
diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 6b464542a5..c7e1fbea9f 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -99,11 +99,11 @@ data RealSrcLoc
   = SrcLoc      FastString              -- A precise location (file name)
                 {-# UNPACK #-} !Int     -- line number, begins at 1
                 {-# UNPACK #-} !Int     -- column number, begins at 1
-  deriving Show
 
 data SrcLoc
   = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
   | UnhelpfulLoc FastString     -- Just a general indication
+  deriving Show
 \end{code}
 
 %************************************************************************
@@ -259,8 +259,7 @@ data RealSrcSpan
           srcSpanLine     :: {-# UNPACK #-} !Int,
           srcSpanCol      :: {-# UNPACK #-} !Int
         }
-  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, because we
-                                -- derive Show for Token
+  deriving (Eq, Typeable)
 
 data SrcSpan =
     RealSrcSpan !RealSrcSpan
@@ -433,6 +432,21 @@ instance Ord SrcSpan where
      (srcSpanStart a `compare` srcSpanStart b) `thenCmp`
      (srcSpanEnd   a `compare` srcSpanEnd   b)
 
+instance Show RealSrcLoc where
+  show (SrcLoc filename row col)
+      = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col
+
+-- Show is used by Lexer.x, because we derive Show for Token
+instance Show RealSrcSpan where
+  show (SrcSpanOneLine file l sc ec)
+    = "SrcSpanOneLine " ++ show file ++ " "
+                        ++ intercalate " " (map show [l,sc,ec])
+  show (SrcSpanMultiLine file sl sc el ec)
+    = "SrcSpanMultiLine " ++ show file ++ " "
+                          ++ intercalate " " (map show [sl,sc,el,ec])
+  show (SrcSpanPoint file l c)
+    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [l,c])
+
 
 instance Outputable RealSrcSpan where
     ppr span = pprUserRealSpan True span
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 188233d1ea..c9399b3ba1 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -992,9 +992,12 @@ lowerSafeForeignCall dflags block
     id <- newTemp (bWord dflags)
     new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
     let (caller_save, caller_load) = callerSaveVolatileRegs dflags
-    load_tso <- newTemp (gcWord dflags)
     load_stack <- newTemp (gcWord dflags)
-    let suspend = saveThreadState dflags <*>
+    tso <- newTemp (gcWord dflags)
+    cn <- newTemp (bWord dflags)
+    bdfree <- newTemp (bWord dflags)
+    bdstart <- newTemp (bWord dflags)
+    let suspend = saveThreadState dflags tso cn  <*>
                   caller_save <*>
                   mkMiddle (callSuspendThread dflags id intrbl)
         midCall = mkUnsafeCall tgt res args
@@ -1003,7 +1006,7 @@ lowerSafeForeignCall dflags block
                   -- might now have a different Capability!
                   mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
                   caller_load <*>
-                  loadThreadState dflags load_tso load_stack
+                  loadThreadState dflags tso load_stack cn bdfree bdstart
 
         (_, regs, copyout) =
              copyOutOflow dflags NativeReturn Jump (Young succ)
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index b84cb40c69..e9215d5021 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -3,7 +3,7 @@
 module CmmMachOp
     ( MachOp(..)
     , pprMachOp, isCommutableMachOp, isAssociativeMachOp
-    , isComparisonMachOp, machOpResultType
+    , isComparisonMachOp, maybeIntComparison, machOpResultType
     , machOpArgReps, maybeInvertComparison
 
     -- MachOp builders
@@ -11,9 +11,11 @@ module CmmMachOp
     , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
     , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
     , mo_wordULe, mo_wordUGt, mo_wordULt
-    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot
+    , mo_wordShl, mo_wordSShr, mo_wordUShr
     , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
-    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord
+    , mo_u_32ToWord, mo_s_32ToWord
     , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
 
     -- CallishMachOp
@@ -260,6 +262,7 @@ isAssociativeMachOp mop =
         MO_Xor {} -> True
         _other    -> False
 
+
 -- ----------------------------------------------------------------------------
 -- isComparisonMachOp
 
@@ -290,6 +293,25 @@ isComparisonMachOp mop =
     MO_F_Lt {} -> True
     _other     -> False
 
+{- |
+Returns @Just w@ if the operation is an integer comparison with width
+@w@, or @Nothing@ otherwise.
+-}
+maybeIntComparison :: MachOp -> Maybe Width
+maybeIntComparison mop =
+  case mop of
+    MO_Eq   w  -> Just w
+    MO_Ne   w  -> Just w
+    MO_S_Ge w  -> Just w
+    MO_S_Le w  -> Just w
+    MO_S_Gt w  -> Just w
+    MO_S_Lt w  -> Just w
+    MO_U_Ge w  -> Just w
+    MO_U_Le w  -> Just w
+    MO_U_Gt w  -> Just w
+    MO_U_Lt w  -> Just w
+    _ -> Nothing
+
 -- -----------------------------------------------------------------------------
 -- Inverting conditions
 
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index f5511515a9..4fbf42e607 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -3,7 +3,6 @@
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fprof-auto-top #-}
 
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index eb1c7da76d..c2e276ed0b 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -9,12 +9,15 @@
 -----------------------------------------------------------------------------
 
 module StgCmmForeign (
-  cgForeignCall, loadThreadState, saveThreadState,
+  cgForeignCall,
   emitPrimCall, emitCCall,
   emitForeignCall,     -- For CmmParse
-  emitSaveThreadState, -- will be needed by the Cmm parser
-  emitLoadThreadState, -- ditto
-  emitCloseNursery, emitOpenNursery
+  emitSaveThreadState,
+  saveThreadState,
+  emitLoadThreadState,
+  loadThreadState,
+  emitOpenNursery,
+  emitCloseNursery,
  ) where
 
 #include "HsVersions.h"
@@ -271,94 +274,221 @@ maybe_assign_temp e = do
 -- This stuff can't be done in suspendThread/resumeThread, because it
 -- refers to global registers which aren't available in the C world.
 
-saveThreadState :: DynFlags -> CmmAGraph
-saveThreadState dflags =
-  -- CurrentTSO->stackobj->sp = Sp;
-  mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp
-  <*> closeNursery dflags
-  -- and save the current cost centre stack in the TSO when profiling:
-  <*> if gopt Opt_SccProfilingOn dflags then
-        mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS
-      else mkNop
-
 emitSaveThreadState :: FCode ()
 emitSaveThreadState = do
   dflags <- getDynFlags
-  emit (saveThreadState dflags)
+  tso <- newTemp (gcWord dflags)
+  cn <- newTemp (bWord dflags)
+  emit $ saveThreadState dflags tso cn
+
+
+-- saveThreadState must be usable from the stack layout pass, where we
+-- don't have FCode.  Therefore it takes LocalRegs as arguments, so
+-- the caller can create these.
+saveThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
+saveThreadState dflags tso cn =
+  catAGraphs [
+    -- tso = CurrentTSO;
+    mkAssign (CmmLocal tso) stgCurrentTSO,
+    -- tso->stackobj->sp = Sp;
+    mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp,
+    closeNursery dflags tso cn,
+    -- and save the current cost centre stack in the TSO when profiling:
+    if gopt Opt_SccProfilingOn dflags then
+        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS
+      else mkNop
+    ]
 
 emitCloseNursery :: FCode ()
 emitCloseNursery = do
-  df <- getDynFlags
-  emit (closeNursery df)
+  dflags <- getDynFlags
+  tso <- newTemp (gcWord dflags)
+  cn <- newTemp (bWord dflags)
+  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
+         closeNursery dflags tso cn
+
+{-
+Closing the nursery corresponds to the following code:
+
+  tso = CurrentTSO;
+  cn = CurrentNuresry;
 
-   -- CurrentNursery->free = Hp+1;
-closeNursery :: DynFlags -> CmmAGraph
-closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags stgHp 1)
+  // Update the allocation limit for the current thread.  We don't
+  // check to see whether it has overflowed at this point, that check is
+  // made when we run out of space in the current heap block (stg_gc_noregs)
+  // and in the scheduler when context switching (schedulePostRunThread).
+  tso->alloc_limit -= Hp + WDS(1) - cn->start;
 
-loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
-loadThreadState dflags tso stack = do
+  // Set cn->free to the next unoccupied word in the block
+  cn->free = Hp + WDS(1);
+-}
+
+closeNursery :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
+closeNursery df tso cn =
+  let
+      tsoreg     = CmmLocal tso
+      cnreg      = CmmLocal cn
+  in
   catAGraphs [
-        -- tso = CurrentTSO;
-        mkAssign (CmmLocal tso) stgCurrentTSO,
-        -- stack = tso->stackobj;
-        mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
-        -- Sp = stack->sp;
-        mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
-        -- SpLim = stack->stack + RESERVED_STACK_WORDS;
-        mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
-                                    (rESERVED_STACK_WORDS dflags)),
-        -- HpAlloc = 0;
-        --   HpAlloc is assumed to be set to non-zero only by a failed
-        --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
-        mkAssign hpAlloc (zeroExpr dflags),
-
-        openNursery dflags,
-        -- and load the current cost centre stack from the TSO when profiling:
-        if gopt Opt_SccProfilingOn dflags then
-          storeCurCCS
-            (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags))
-        else mkNop]
+    mkAssign cnreg stgCurrentNursery,
+
+    -- CurrentNursery->free = Hp+1;
+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1),
+
+    let alloc =
+           CmmMachOp (mo_wordSub df)
+              [ cmmOffsetW df stgHp 1
+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
+              ]
+
+        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+    in
+
+    -- tso->alloc_limit += alloc
+    mkStore alloc_limit (CmmMachOp (MO_Sub W64)
+                               [ CmmLoad alloc_limit b64
+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])
+   ]
 
 emitLoadThreadState :: FCode ()
 emitLoadThreadState = do
   dflags <- getDynFlags
-  load_tso <- newTemp (gcWord dflags)
-  load_stack <- newTemp (gcWord dflags)
-  emit $ loadThreadState dflags load_tso load_stack
+  tso <- newTemp (gcWord dflags)
+  stack <- newTemp (gcWord dflags)
+  cn <- newTemp (bWord dflags)
+  bdfree <- newTemp (bWord dflags)
+  bdstart <- newTemp (bWord dflags)
+  emit $ loadThreadState dflags tso stack cn bdfree bdstart
+
+-- loadThreadState must be usable from the stack layout pass, where we
+-- don't have FCode.  Therefore it takes LocalRegs as arguments, so
+-- the caller can create these.
+loadThreadState :: DynFlags
+                -> LocalReg -> LocalReg -> LocalReg -> LocalReg -> LocalReg
+                -> CmmAGraph
+loadThreadState dflags tso stack cn bdfree bdstart =
+  catAGraphs [
+    -- tso = CurrentTSO;
+    mkAssign (CmmLocal tso) stgCurrentTSO,
+    -- stack = tso->stackobj;
+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
+    -- Sp = stack->sp;
+    mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
+    -- SpLim = stack->stack + RESERVED_STACK_WORDS;
+    mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
+                                (rESERVED_STACK_WORDS dflags)),
+    -- HpAlloc = 0;
+    --   HpAlloc is assumed to be set to non-zero only by a failed
+    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
+    mkAssign hpAlloc (zeroExpr dflags),
+    openNursery dflags tso cn bdfree bdstart,
+    -- and load the current cost centre stack from the TSO when profiling:
+    if gopt Opt_SccProfilingOn dflags
+       then storeCurCCS
+              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))
+                 (tso_CCCS dflags)) (ccsType dflags))
+       else mkNop
+   ]
+
 
 emitOpenNursery :: FCode ()
 emitOpenNursery = do
-  df <- getDynFlags
-  emit (openNursery df)
-
-openNursery :: DynFlags -> CmmAGraph
-openNursery dflags = catAGraphs [
-        -- Hp = CurrentNursery->free - 1;
-        mkAssign hp (cmmOffsetW dflags (CmmLoad (nursery_bdescr_free dflags) (bWord dflags)) (-1)),
-
-        -- HpLim = CurrentNursery->start +
-        --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-        mkAssign hpLim
-            (cmmOffsetExpr dflags
-                (CmmLoad (nursery_bdescr_start dflags) (bWord dflags))
-                (cmmOffset dflags
-                  (CmmMachOp (mo_wordMul dflags) [
-                    CmmMachOp (MO_SS_Conv W32 (wordWidth dflags))
-                      [CmmLoad (nursery_bdescr_blocks dflags) b32],
-                    mkIntExpr dflags (bLOCK_SIZE dflags)
-                   ])
-                  (-1)
-                )
-            )
+  dflags <- getDynFlags
+  tso <- newTemp (gcWord dflags)
+  cn <- newTemp (bWord dflags)
+  bdfree <- newTemp (bWord dflags)
+  bdstart <- newTemp (bWord dflags)
+  emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
+         openNursery dflags tso cn bdfree bdstart
+
+{-
+Opening the nursery corresponds to the following code:
+
+   tso = CurrentTSO;
+   cn = CurrentNursery;
+   bdfree = CurrentNuresry->free;
+   bdstart = CurrentNuresry->start;
+
+   // We *add* the currently occupied portion of the nursery block to
+   // the allocation limit, because we will subtract it again in
+   // closeNursery.
+   tso->alloc_limit += bdfree - bdstart;
+
+   // Set Hp to the last occupied word of the heap block.  Why not the
+   // next unocupied word?  Doing it this way means that we get to use
+   // an offset of zero more often, which might lead to slightly smaller
+   // code on some architectures.
+   Hp = bdfree - WDS(1);
+
+   // Set HpLim to the end of the current nursery block (note that this block
+   // might be a block group, consisting of several adjacent blocks.
+   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+-}
+
+openNursery :: DynFlags
+            -> LocalReg -> LocalReg -> LocalReg -> LocalReg
+            -> CmmAGraph
+openNursery df tso cn bdfree bdstart =
+  let
+      tsoreg     = CmmLocal tso
+      cnreg      = CmmLocal cn
+      bdfreereg  = CmmLocal bdfree
+      bdstartreg = CmmLocal bdstart
+  in
+  -- These assignments are carefully ordered to reduce register
+  -- pressure and generate not completely awful code on x86.  To see
+  -- what code we generate, look at the assembly for
+  -- stg_returnToStackTop in rts/StgStartup.cmm.
+  catAGraphs [
+     mkAssign cnreg stgCurrentNursery,
+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),
+
+     -- Hp = CurrentNursery->free - 1;
+     mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)),
+
+     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),
+
+     -- HpLim = CurrentNursery->start +
+     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+     mkAssign hpLim
+         (cmmOffsetExpr df
+             (CmmReg bdstartreg)
+             (cmmOffset df
+               (CmmMachOp (mo_wordMul df) [
+                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))
+                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],
+                 mkIntExpr df (bLOCK_SIZE df)
+                ])
+               (-1)
+             )
+         ),
+
+     -- alloc = bd->free - bd->start
+     let alloc =
+           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]
+
+         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+     in
+
+     -- tso->alloc_limit += alloc
+     mkStore alloc_limit (CmmMachOp (MO_Add W64)
+                               [ CmmLoad alloc_limit b64
+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])
+
    ]
 
-nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr
-nursery_bdescr_free   dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags)
-nursery_bdescr_start  dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_start dflags)
-nursery_bdescr_blocks dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_blocks dflags)
+nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
+  :: DynFlags -> CmmReg -> CmmExpr
+nursery_bdescr_free   dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)
+nursery_bdescr_start  dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)
+nursery_bdescr_blocks dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)
 
-tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: DynFlags -> ByteOff
+tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff
 tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)
+tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)
 tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)
 stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)
 stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 374b98ece9..537cc01b43 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -1123,7 +1123,8 @@ lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
     IntegerGMP -> guardIntegerUse dflags $ liftM Just $
                   initTcForLookup hsc_env (tcLookupDataCon integerSDataConName)
-
+    IntegerGMP2-> guardIntegerUse dflags $ liftM Just $
+                  initTcForLookup hsc_env (tcLookupDataCon integerSDataConName)
     IntegerSimple -> return Nothing
 
 -- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 6844f48970..ce2d5a5d4a 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -46,12 +46,14 @@ import MkCore
 import DynFlags
 import CostCentre
 import Id
+import Unique
 import Module
 import VarSet
 import VarEnv
 import ConLike
 import DataCon
 import TysWiredIn
+import PrelNames ( seqIdKey )
 import BasicTypes
 import Maybes
 import SrcLoc
@@ -191,7 +193,12 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)              = dsLExpr e
 dsExpr (ExprWithTySigOut e _) = dsLExpr e
-dsExpr (HsVar var)            = return (varToCoreExpr var)   -- See Note [Desugaring vars]
+dsExpr (HsVar var)            -- See Note [Unfolding while desugaring]
+  | unfold_var = return $ unfoldingTemplate unfolding
+  | otherwise  = return (varToCoreExpr var)   -- See Note [Desugaring vars]
+  where
+    unfold_var = isCompulsoryUnfolding unfolding && not (var `hasKey` seqIdKey)
+    unfolding = idUnfolding var
 dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
 dsExpr (HsLit lit)            = dsLit lit
 dsExpr (HsOverLit lit)        = dsOverLit lit
@@ -220,6 +227,19 @@ dsExpr (HsApp fun arg)
 dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
 \end{code}
 
+Note [Unfolding while desugaring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Variables with compulsory unfolding must be substituted at desugaring
+time. This is needed to preserve the let/app invariant in cases where
+the unfolding changes whether wrapping in a case is needed.
+Suppose we have a call like this:
+    I# x
+where 'x' has an unfolding like this:
+    f void#
+In this case, 'mkCoreAppDs' needs to see 'f void#', not 'x', to be
+able to do the right thing.
+
+
 Note [Desugaring vars]
 ~~~~~~~~~~~~~~~~~~~~~~
 In one situation we can get a *coercion* variable in a HsVar, namely
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 24785c257f..083c466baa 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -137,26 +137,26 @@ repTopDs group@(HsGroup { hs_valds   = valds
         -- only "T", not "Foo:T" where Foo is the current module
 
         decls <- addBinds ss (
-                  do { val_ds  <- rep_val_binds valds
-                     ; _       <- mapM no_splice splcds
-                     ; tycl_ds <- mapM repTyClD (tyClGroupConcat tyclds)
-                     ; role_ds <- mapM repRoleD (concatMap group_roles tyclds)
-                     ; inst_ds <- mapM repInstD instds
-                     ; _       <- mapM no_standalone_deriv derivds
-                     ; fix_ds  <- mapM repFixD fixds
-                     ; _       <- mapM no_default_decl defds
-                     ; for_ds  <- mapM repForD fords
-                     ; _       <- mapM no_warn warnds
-                     ; ann_ds  <- mapM repAnnD annds
-                     ; rule_ds <- mapM repRuleD ruleds
-                     ; _       <- mapM no_vect vects
-                     ; _       <- mapM no_doc docs
+                  do { val_ds   <- rep_val_binds valds
+                     ; _        <- mapM no_splice splcds
+                     ; tycl_ds  <- mapM repTyClD (tyClGroupConcat tyclds)
+                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
+                     ; inst_ds  <- mapM repInstD instds
+                     ; deriv_ds <- mapM repStandaloneDerivD derivds
+                     ; fix_ds   <- mapM repFixD fixds
+                     ; _        <- mapM no_default_decl defds
+                     ; for_ds   <- mapM repForD fords
+                     ; _        <- mapM no_warn warnds
+                     ; ann_ds   <- mapM repAnnD annds
+                     ; rule_ds  <- mapM repRuleD ruleds
+                     ; _        <- mapM no_vect vects
+                     ; _        <- mapM no_doc docs
 
                         -- more needed
                      ;  return (de_loc $ sort_by_loc $
                                 val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds
                                        ++ inst_ds ++ rule_ds ++ for_ds
-                                       ++ ann_ds) }) ;
+                                       ++ ann_ds ++ deriv_ds) }) ;
 
         decl_ty <- lookupType decQTyConName ;
         let { core_list = coreList' decl_ty decls } ;
@@ -169,8 +169,6 @@ repTopDs group@(HsGroup { hs_valds   = valds
   where
     no_splice (L loc _)
       = notHandledL loc "Splices within declaration brackets" empty
-    no_standalone_deriv (L loc (DerivDecl { deriv_type = deriv_ty }))
-      = notHandledL loc "Standalone-deriving" (ppr deriv_ty)
     no_default_decl (L loc decl)
       = notHandledL loc "Default declarations" (ppr decl)
     no_warn (L loc (Warning thing _))
@@ -422,6 +420,18 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
  where
    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
 
+repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
+repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
+  = do { dec <- addTyVarBinds tvs $ \_ ->
+                do { cxt' <- repContext cxt
+                   ; cls_tcon <- repTy (HsTyVar (unLoc cls))
+                   ; cls_tys <- repLTys tys
+                   ; inst_ty <- repTapps cls_tcon cls_tys
+                   ; repDeriv cxt' inst_ty }
+       ; return (loc, dec) }
+  where
+    Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
+
 repTyFamInstD :: TyFamInstDecl Name -> DsM (Core TH.DecQ)
 repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
   = do { let tc_name = tyFamInstDeclLName decl
@@ -662,10 +672,9 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
                      return (concat sigs1) }
 
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
-rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig loc ty) nms
+rep_sig (L loc (TypeSig nms ty))      = mapM (rep_ty_sig sigDName loc ty) nms
 rep_sig (L _   (PatSynSig {}))        = notHandled "Pattern type signatures" empty
-rep_sig (L _   (GenericSig nm _))     = notHandled "Default type signatures" msg
-  where msg = text "Illegal default signature for" <+> quotes (ppr nm)
+rep_sig (L loc (GenericSig nms ty))   = mapM (rep_ty_sig defaultSigDName loc ty) nms
 rep_sig d@(L _ (IdSig {}))            = pprPanic "rep_sig IdSig" (ppr d)
 rep_sig (L _   (FixSig {}))           = return [] -- fixity sigs at top level
 rep_sig (L loc (InlineSig nm ispec))  = rep_inline nm ispec loc
@@ -673,12 +682,12 @@ rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc
 rep_sig (L loc (SpecInstSig ty))      = rep_specialiseInst ty loc
 rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
 
-rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name
+rep_ty_sig :: Name -> SrcSpan -> LHsType Name -> Located Name
            -> DsM (SrcSpan, Core TH.DecQ)
-rep_ty_sig loc (L _ ty) nm
+rep_ty_sig mk_sig loc (L _ ty) nm
   = do { nm1 <- lookupLOcc nm
        ; ty1 <- rep_ty ty
-       ; sig <- repProto nm1 ty1
+       ; sig <- repProto mk_sig nm1 ty1
        ; return (loc, sig) }
   where
     -- We must special-case the top-level explicit for-all of a TypeSig
@@ -693,7 +702,6 @@ rep_ty_sig loc (L _ ty) nm
 
     rep_ty ty = repTy ty
 
-
 rep_inline :: Located Name
            -> InlinePragma      -- Never defaultInlinePragma
            -> SrcSpan
@@ -1741,6 +1749,9 @@ repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndr]
 repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
   = rep2 classDName [cxt, cls, tvs, fds, ds]
 
+repDeriv :: Core TH.CxtQ -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repDeriv (MkC cxt) (MkC ty) = rep2 standaloneDerivDName [cxt, ty]
+
 repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
            -> Core TH.Phases -> DsM (Core TH.DecQ)
 repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
@@ -1807,8 +1818,8 @@ repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
 repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
 repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
 
-repProto :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
-repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty]
+repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
 
 repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
 repCtxt (MkC tys) = rep2 cxtName [tys]
@@ -2105,9 +2116,9 @@ templateHaskellNames = [
     bindSName, letSName, noBindSName, parSName,
     -- Dec
     funDName, valDName, dataDName, newtypeDName, tySynDName,
-    classDName, instanceDName, sigDName, forImpDName,
+    classDName, instanceDName, standaloneDerivDName, sigDName, forImpDName,
     pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
-    pragRuleDName, pragAnnDName,
+    pragRuleDName, pragAnnDName, defaultSigDName,
     familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName,
     tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
     infixLDName, infixRDName, infixNDName,
@@ -2333,7 +2344,7 @@ parSName    = libFun (fsLit "parS")    parSIdKey
 funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
     instanceDName, sigDName, forImpDName, pragInlDName, pragSpecDName,
     pragSpecInlDName, pragSpecInstDName, pragRuleDName, pragAnnDName,
-    familyNoKindDName,
+    familyNoKindDName, standaloneDerivDName, defaultSigDName,
     familyKindDName, dataInstDName, newtypeInstDName, tySynInstDName,
     closedTypeFamilyKindDName, closedTypeFamilyNoKindDName,
     infixLDName, infixRDName, infixNDName, roleAnnotDName :: Name
@@ -2344,7 +2355,10 @@ newtypeDName      = libFun (fsLit "newtypeD")      newtypeDIdKey
 tySynDName        = libFun (fsLit "tySynD")        tySynDIdKey
 classDName        = libFun (fsLit "classD")        classDIdKey
 instanceDName     = libFun (fsLit "instanceD")     instanceDIdKey
+standaloneDerivDName
+                  = libFun (fsLit "standaloneDerivD") standaloneDerivDIdKey
 sigDName          = libFun (fsLit "sigD")          sigDIdKey
+defaultSigDName   = libFun (fsLit "defaultSigD")   defaultSigDIdKey
 forImpDName       = libFun (fsLit "forImpD")       forImpDIdKey
 pragInlDName      = libFun (fsLit "pragInlD")      pragInlDIdKey
 pragSpecDName     = libFun (fsLit "pragSpecD")     pragSpecDIdKey
@@ -2696,8 +2710,8 @@ parSIdKey        = mkPreludeMiscIdUnique 323
 funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey,
     classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey,
     pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey, pragRuleDIdKey,
-    pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey,
-    dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey,
+    pragAnnDIdKey, familyNoKindDIdKey, familyKindDIdKey, defaultSigDIdKey,
+    dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivDIdKey,
     closedTypeFamilyKindDIdKey, closedTypeFamilyNoKindDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey :: Unique
 funDIdKey                    = mkPreludeMiscIdUnique 330
@@ -2726,6 +2740,8 @@ infixLDIdKey                 = mkPreludeMiscIdUnique 352
 infixRDIdKey                 = mkPreludeMiscIdUnique 353
 infixNDIdKey                 = mkPreludeMiscIdUnique 354
 roleAnnotDIdKey              = mkPreludeMiscIdUnique 355
+standaloneDerivDIdKey        = mkPreludeMiscIdUnique 356
+defaultSigDIdKey             = mkPreludeMiscIdUnique 357
 
 -- type Cxt = ...
 cxtIdKey :: Unique
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index c017a7cc01..1c707c4afc 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -221,7 +221,7 @@ initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
         }
   where
     -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
-    --   * 'Data.Array.Parallel'      iff '-XParallalArrays' specified (see also 'checkLoadDAP').
+    --   * 'Data.Array.Parallel'      iff '-XParallelArrays' specified (see also 'checkLoadDAP').
     --   * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
     loadDAP thing_inside
       = do { dapEnv  <- loadOneModule dATA_ARRAY_PARALLEL_NAME      checkLoadDAP          paErr
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index b5f5dbce8f..fb8aa730e8 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -53,8 +53,10 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
 	@echo                                                               >> $@
 	@echo '#include "ghc_boot_platform.h"'                              >> $@
 	@echo                                                               >> $@
-	@echo 'data IntegerLibrary = IntegerGMP | IntegerSimple'            >> $@
-	@echo '    deriving Eq'                                             >> $@
+	@echo 'data IntegerLibrary = IntegerGMP'                            >> $@
+	@echo '                    | IntegerGMP2'                           >> $@
+	@echo '                    | IntegerSimple'                         >> $@
+	@echo '                    deriving Eq'                             >> $@
 	@echo                                                               >> $@
 	@echo 'cBuildPlatformString :: String'                              >> $@
 	@echo 'cBuildPlatformString = BuildPlatform_NAME'                   >> $@
@@ -84,6 +86,8 @@ compiler/stage%/build/Config.hs : mk/config.mk mk/project.mk | $$(dir $$@)/.
 	@echo 'cIntegerLibraryType   :: IntegerLibrary'                     >> $@
 ifeq "$(INTEGER_LIBRARY)" "integer-gmp"
 	@echo 'cIntegerLibraryType   = IntegerGMP'                          >> $@
+else ifeq "$(INTEGER_LIBRARY)" "integer-gmp2"
+	@echo 'cIntegerLibraryType   = IntegerGMP2'                         >> $@
 else ifeq "$(INTEGER_LIBRARY)" "integer-simple"
 	@echo 'cIntegerLibraryType   = IntegerSimple'                       >> $@
 else ifneq "$(CLEANING)" "YES"
@@ -570,6 +574,7 @@ compiler_stage2_dll0_MODULES = \
 	StringBuffer \
 	TcEvidence \
 	TcIface \
+	TcMType \
 	TcRnMonad \
 	TcRnTypes \
 	TcType \
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 43d9bfb4e9..9ad594c698 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -6,7 +6,6 @@
 This module converts Template Haskell syntax into HsSyn
 
 \begin{code}
-{-# LANGUAGE MagicHash #-}
 {-# LANGUAGE CPP #-}
 
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
@@ -44,7 +43,6 @@ import Control.Applicative (Applicative(..))
 import Data.Maybe( catMaybes )
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
-import GHC.Exts
 
 -------------------------------------------------------------------
 --              The external interface
@@ -172,7 +170,11 @@ cvtDec (TH.SigD nm typ)
         ; returnJustL $ Hs.SigD (TypeSig [nm'] ty') }
 
 cvtDec (TH.InfixD fx nm)
-  = do { nm' <- vNameL nm
+  -- fixity signatures are allowed for variables, constructors, and types
+  -- the renamer automatically looks for types during renaming, even when
+  -- the RdrName says it's a variable or a constructor. So, just assume
+  -- it's a variable or constructor and proceed.
+  = do { nm' <- vcNameL nm
        ; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
 
 cvtDec (PragmaD prag)
@@ -303,6 +305,18 @@ cvtDec (TH.RoleAnnotD tc roles)
   = do { tc' <- tconNameL tc
        ; let roles' = map (noLoc . cvtRole) roles
        ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
+
+cvtDec (TH.StandaloneDerivD cxt ty)
+  = do { cxt' <- cvtContext cxt
+       ; L loc ty'  <- cvtType ty
+       ; let inst_ty' = L loc $ mkImplicitHsForAllTy cxt' $ L loc ty'
+       ; returnJustL $ DerivD $
+         DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
+
+cvtDec (TH.DefaultSigD nm typ)
+  = do { nm' <- vNameL nm
+       ; ty' <- cvtType typ
+       ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' }
 ----------------
 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
 cvtTySynEqn tc (TySynEqn lhs rhs)
@@ -521,7 +535,7 @@ cvtPragmaD (AnnP target exp)
            n' <- tconName n
            return (TypeAnnProvenance  n')
          ValueAnnotation n -> do
-           n' <- if isVarName n then vName n else cName n
+           n' <- vcName n
            return (ValueAnnProvenance n')
        ; returnJustL $ Hs.AnnD $ HsAnnotation target' exp'
        }
@@ -1071,9 +1085,10 @@ cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value =
 --------------------------------------------------------------------
 
 -- variable names
-vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
-vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
+vNameL, cNameL, vcNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
+vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 
+-- Variable names
 vNameL n = wrapL (vName n)
 vName n = cvtName OccName.varName n
 
@@ -1081,6 +1096,10 @@ vName n = cvtName OccName.varName n
 cNameL n = wrapL (cName n)
 cName n = cvtName OccName.dataName n
 
+-- Variable *or* constructor names; check by looking at the first char
+vcNameL n = wrapL (vcName n)
+vcName n = if isVarName n then vName n else cName n
+
 -- Type variable names
 tName n = cvtName OccName.tvName n
 
@@ -1181,8 +1200,8 @@ mk_mod mod = mkModuleName (TH.modString mod)
 mk_pkg :: TH.PkgName -> PackageKey
 mk_pkg pkg = stringToPackageKey (TH.pkgString pkg)
 
-mk_uniq :: Int# -> Unique
-mk_uniq u = mkUniqueGrimily (I# u)
+mk_uniq :: Int -> Unique
+mk_uniq u = mkUniqueGrimily u
 \end{code}
 
 Note [Binders in Template Haskell]
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 12e2388684..df2406fcd3 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -28,7 +28,7 @@ module HsUtils(
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdCast,
 
-  nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
+  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
   toHsType, toHsKind,
@@ -177,6 +177,9 @@ mkSimpleHsAlt pat expr
 nlHsTyApp :: name -> [Type] -> LHsExpr name
 nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
 
+nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
+nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
+
 --------- Adding parens ---------
 mkLHsPar :: LHsExpr name -> LHsExpr name
 -- Wrap in parens if hsExprNeedsParens says it needs them
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index d90e63c972..106a15fc9a 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -179,7 +179,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 
 ------------------------------------------------------
 buildPatSyn :: Name -> Bool
-            -> Id -> Maybe Id
+            -> Id -> Maybe (Id, Id)
             -> ([TyVar], ThetaType) -- ^ Univ and req
             -> ([TyVar], ThetaType) -- ^ Ex and prov
             -> [Type]               -- ^ Argument types
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 5cfe773dc8..c2b7c5276b 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -128,7 +128,7 @@ data IfaceDecl
   | IfacePatSyn { ifName          :: IfaceTopBndr,           -- Name of the pattern synonym
                   ifPatIsInfix    :: Bool,
                   ifPatMatcher    :: IfExtName,
-                  ifPatWrapper    :: Maybe IfExtName,
+                  ifPatWorker     :: Maybe IfExtName,
                   -- Everything below is redundant,
                   -- but needed to implement pprIfaceDecl
                   ifPatUnivTvs    :: [IfaceTvBndr],
@@ -759,15 +759,15 @@ pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars
         $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
     pp_branches _ = Outputable.empty
 
-pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
+pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWorker = worker,
                               ifPatIsInfix = is_infix,
                               ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
                               ifPatArgs = args,
                               ifPatTy = ty })
-  = pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
+  = pprPatSynSig name is_bidirectional args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
   where
-    has_wrap = isJust wrapper
+    is_bidirectional = isJust worker
     args' = case (is_infix, args) of
         (True, [left_ty, right_ty]) ->
             InfixPatSyn (pprParendIfaceType left_ty) (pprParendIfaceType right_ty)
@@ -1131,7 +1131,7 @@ freeNamesIfDecl d@IfaceAxiom{} =
   fnList freeNamesIfAxBranch (ifAxBranches d)
 freeNamesIfDecl d@IfacePatSyn{} =
   unitNameSet (ifPatMatcher d) &&&
-  maybe emptyNameSet unitNameSet (ifPatWrapper d) &&&
+  maybe emptyNameSet unitNameSet (ifPatWorker d) &&&
   freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
   freeNamesIfTvBndrs (ifPatExTvs d) &&&
   freeNamesIfContext (ifPatProvCtxt d) &&&
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index faaea6c456..3b2f7f25c9 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -92,7 +92,7 @@ loadSrcInterface doc mod want_boot maybe_pkg
            Failed err      -> failWithTc err
            Succeeded iface -> return iface }
 
--- | Like loadSrcInterface, but returns a MaybeErr
+-- | Like 'loadSrcInterface', but returns a 'MaybeErr'.
 loadSrcInterface_maybe :: SDoc
                        -> ModuleName
                        -> IsBootInterface     -- {-# SOURCE #-} ?
@@ -111,7 +111,10 @@ loadSrcInterface_maybe doc mod want_boot maybe_pkg
            Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
            err         -> return (Failed (cannotFindInterface (hsc_dflags hsc_env) mod err)) }
 
--- | Load interface for a module.
+-- | Load interface directly for a fully qualified 'Module'.  (This is a fairly
+-- rare operation, but in particular it is used to load orphan modules
+-- in order to pull their instances into the global package table and to
+-- handle some operations in GHCi).
 loadModuleInterface :: SDoc -> Module -> TcM ModIface
 loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)
 
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 78111b299e..95fe479447 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1534,7 +1534,7 @@ patSynToIfaceDecl :: PatSyn -> IfaceDecl
 patSynToIfaceDecl ps
   = IfacePatSyn { ifName          = getOccName . getName $ ps
                 , ifPatMatcher    = matcher
-                , ifPatWrapper    = wrapper
+                , ifPatWorker     = worker
                 , ifPatIsInfix    = patSynIsInfix ps
                 , ifPatUnivTvs    = toIfaceTvBndrs univ_tvs'
                 , ifPatExTvs      = toIfaceTvBndrs ex_tvs'
@@ -1549,7 +1549,7 @@ patSynToIfaceDecl ps
     (env2, ex_tvs')   = tidyTyVarBndrs env1 ex_tvs
 
     matcher = idName (patSynMatcher ps)
-    wrapper = fmap idName (patSynWrapper ps)
+    worker = fmap idName (patSynWorker ps)
 
 
 --------------------------
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 65345ec3c8..85ea0f94cc 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -14,7 +14,8 @@ module TcIface (
         tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
         tcIfaceVectInfo, tcIfaceAnnotations,
         tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)
-        tcIfaceGlobal
+        tcIfaceGlobal,
+        mkPatSynWrapperId, mkPatSynWorkerId -- Have to be here to avoid circular import
  ) where
 
 #include "HsVersions.h"
@@ -27,7 +28,8 @@ import BuildTyCl
 import TcRnMonad
 import TcType
 import Type
-import Coercion
+import TcMType
+import Coercion hiding (substTy)
 import TypeRep
 import HscTypes
 import Annotations
@@ -37,7 +39,7 @@ import CoreSyn
 import CoreUtils
 import CoreUnfold
 import CoreLint
-import MkCore                       ( castBottomExpr )
+import MkCore
 import Id
 import MkId
 import IdInfo
@@ -75,6 +77,7 @@ import qualified Data.Map as Map
 #if __GLASGOW_HASKELL__ < 709
 import Data.Traversable ( traverse )
 #endif
+import Data.Traversable ( for )
 \end{code}
 
 This module takes
@@ -181,9 +184,9 @@ We need to make sure that we have at least *read* the interface files
 for any module with an instance decl or RULE that we might want.
 
 * If the instance decl is an orphan, we have a whole separate mechanism
-  (loadOprhanModules)
+  (loadOrphanModules)
 
-* If the instance decl not an orphan, then the act of looking at the
+* If the instance decl is not an orphan, then the act of looking at the
   TyCon or Class will force in the defining module for the
   TyCon/Class, and hence the instance decl
 
@@ -582,7 +585,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
 
 tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                               , ifPatMatcher = matcher_name
-                              , ifPatWrapper = wrapper_name
+                              , ifPatWorker = worker_name
                               , ifPatIsInfix = is_infix
                               , ifPatUnivTvs = univ_tvs
                               , ifPatExTvs = ex_tvs
@@ -593,10 +596,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
   = do { name <- lookupIfaceTop occ_name
        ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
        ; matcher <- tcExt "Matcher" matcher_name
-       ; wrapper <- case wrapper_name of
-                        Nothing -> return Nothing
-                        Just wn -> do { wid <- tcExt "Wrapper" wn
-                                      ; return (Just wid) }
+       ; worker <- traverse (tcExt "Worker") worker_name
        ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
        { bindIfaceTyVars ex_tvs $ \ex_tvs -> do
        { patsyn <- forkM (mk_doc name) $
@@ -604,6 +604,14 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
                 ; req_theta  <- tcIfaceCtxt req_ctxt
                 ; pat_ty     <- tcIfaceType pat_ty
                 ; arg_tys    <- mapM tcIfaceType args
+                ; wrapper    <- for worker $ \worker_id -> do
+                    { wrapper_id <- mkPatSynWrapperId (noLoc name)
+                                      (univ_tvs ++ ex_tvs)
+                                      (req_theta ++ prov_theta)
+                                      arg_tys pat_ty
+                                      worker_id
+                    ; return (wrapper_id, worker_id)
+                    }
                 ; return $ buildPatSyn name is_infix matcher wrapper
                                        (univ_tvs, req_theta) (ex_tvs, prov_theta)
                                        arg_tys pat_ty }
@@ -1520,3 +1528,41 @@ bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
          bindIfaceTyVars_AT bs $ \bs' ->
          thing_inside (b':bs') }
 \end{code}
+
+%************************************************************************
+%*                                                                      *
+                PatSyn wrapper/worker helpers
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+-- These are here (and not in TcPatSyn) just to avoid circular imports.
+
+mkPatSynWrapperId :: Located Name
+                  -> [TyVar] -> ThetaType -> [Type] -> Type
+                  -> Id
+                  -> TcRnIf gbl lcl Id
+mkPatSynWrapperId name qtvs theta arg_tys pat_ty worker_id
+  | need_dummy_arg = do
+      { wrapper_id <- mkPatSynWorkerId name mkDataConWrapperOcc qtvs theta arg_tys pat_ty
+      ; let unfolding = mkCoreApp (Var worker_id) (Var voidPrimId)
+            wrapper_id' = setIdUnfolding wrapper_id $ mkCompulsoryUnfolding unfolding
+      ; return wrapper_id' }
+  | otherwise = return worker_id -- No indirection needed
+  where
+    need_dummy_arg = null arg_tys && isUnLiftedType pat_ty
+
+mkPatSynWorkerId :: Located Name -> (OccName -> OccName)
+                 -> [TyVar] -> ThetaType -> [Type] -> Type
+                 -> TcRnIf gbl loc Id
+mkPatSynWorkerId (L loc name) mk_occ_name qtvs theta arg_tys pat_ty
+  = do { worker_name <- newImplicitBinder name mk_occ_name
+       ; (subst, worker_tvs) <- tcInstSigTyVarsLoc loc qtvs
+       ; let worker_theta = substTheta subst theta
+             pat_ty' = substTy subst pat_ty
+             arg_tys' = map (substTy subst) arg_tys
+             worker_tau = mkFunTys arg_tys' pat_ty'
+             -- TODO: just substitute worker_sigma...
+             worker_sigma = mkSigmaTy worker_tvs worker_theta worker_tau
+       ; return $ mkVanillaGlobal worker_name worker_sigma }
+\end{code}
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 0c6639a048..043174f3b0 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -482,6 +482,7 @@ data WarningFlag =
    | Opt_WarnAlternativeLayoutRuleTransitional
    | Opt_WarnUnsafe
    | Opt_WarnSafe
+   | Opt_WarnTrustworthySafe
    | Opt_WarnPointlessPragmas
    | Opt_WarnUnsupportedCallingConventions
    | Opt_WarnUnsupportedLlvmVersion
@@ -778,6 +779,7 @@ data DynFlags = DynFlags {
   pkgTrustOnLoc         :: SrcSpan,
   warnSafeOnLoc         :: SrcSpan,
   warnUnsafeOnLoc       :: SrcSpan,
+  trustworthyOnLoc      :: SrcSpan,
   -- Don't change this without updating extensionFlags:
   extensions            :: [OnOff ExtensionFlag],
   -- extensionFlags should always be equal to
@@ -1466,6 +1468,7 @@ defaultDynFlags mySettings =
         pkgTrustOnLoc = noSrcSpan,
         warnSafeOnLoc = noSrcSpan,
         warnUnsafeOnLoc = noSrcSpan,
+        trustworthyOnLoc = noSrcSpan,
         extensions = [],
         extensionFlags = flattenExtensionFlags Nothing [],
 
@@ -1758,11 +1761,15 @@ setSafeHaskell s = updM f
     where f dfs = do
               let sf = safeHaskell dfs
               safeM <- combineSafeFlags sf s
-              return $ case (s == Sf_Safe || s == Sf_Unsafe) of
-                True  -> dfs { safeHaskell = safeM, safeInfer = False }
+              case s of
+                Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }
                 -- leave safe inferrence on in Trustworthy mode so we can warn
                 -- if it could have been inferred safe.
-                False -> dfs { safeHaskell = safeM }
+                Sf_Trustworthy -> do
+                  l <- getCurLoc
+                  return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }
+                -- leave safe inference on in Unsafe mode as well.
+                _ -> return $ dfs { safeHaskell = safeM }
 
 -- | Are all direct imports required to be safe for this Safe Haskell mode?
 -- Direct imports are when the code explicitly imports a module
@@ -2663,6 +2670,7 @@ fWarningFlags = [
   ( "warn-overlapping-patterns",        Opt_WarnOverlappingPatterns, nop ),
   ( "warn-pointless-pragmas",           Opt_WarnPointlessPragmas, nop ),
   ( "warn-safe",                        Opt_WarnSafe, setWarnSafe ),
+  ( "warn-trustworthy-safe",            Opt_WarnTrustworthySafe, nop ),
   ( "warn-tabs",                        Opt_WarnTabs, nop ),
   ( "warn-type-defaults",               Opt_WarnTypeDefaults, nop ),
   ( "warn-typed-holes",                 Opt_WarnTypedHoles, nop ),
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index bec66f858a..c9baa5ac3e 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -412,19 +412,27 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do
     -- end of the safe haskell line, how to respond to user?
     if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)
         -- if safe Haskell off or safe infer failed, mark unsafe
-        then markUnsafe tcg_res emptyBag
+        then markUnsafeInfer tcg_res emptyBag
 
         -- module (could be) safe, throw warning if needed
         else do
             tcg_res' <- hscCheckSafeImports tcg_res
             safe <- liftIO $ readIORef (tcg_safeInfer tcg_res')
-            when (safe && wopt Opt_WarnSafe dflags)
-                 (logWarnings $ unitBag $ mkPlainWarnMsg dflags
-                     (warnSafeOnLoc dflags) $ errSafe tcg_res')
+            when safe $ do
+              case wopt Opt_WarnSafe dflags of
+                True -> (logWarnings $ unitBag $ mkPlainWarnMsg dflags
+                       (warnSafeOnLoc dflags) $ errSafe tcg_res')
+                False | safeHaskell dflags == Sf_Trustworthy &&
+                        wopt Opt_WarnTrustworthySafe dflags ->
+                  (logWarnings $ unitBag $ mkPlainWarnMsg dflags
+                    (trustworthyOnLoc dflags) $ errTwthySafe tcg_res')
+                False -> return ()
             return tcg_res'
   where
     pprMod t  = ppr $ moduleName $ tcg_mod t
     errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
+    errTwthySafe t = quotes (pprMod t)
+      <+> text "is marked as Trustworthy but has been inferred as safe!"
 
 -- | Convert a typechecked module to Core
 hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
@@ -762,6 +770,18 @@ hscFileFrontEnd mod_summary = do
 --     * For modules explicitly marked -XSafe, we throw the errors.
 --     * For unmarked modules (inference mode), we drop the errors
 --       and mark the module as being Unsafe.
+--
+-- It used to be that we only did safe inference on modules that had no Safe
+-- Haskell flags, but now we perform safe inference on all modules as we want
+-- to allow users to set the `--fwarn-safe`, `--fwarn-unsafe` and
+-- `--fwarn-trustworthy-safe` flags on Trustworthy and Unsafe modules so that a
+-- user can ensure their assumptions are correct and see reasons for why a
+-- module is safe or unsafe.
+--
+-- This is tricky as we must be careful when we should throw an error compared
+-- to just warnings. For checking safe imports we manage it as two steps. First
+-- we check any imports that are required to be safe, then we check all other
+-- imports to see if we can infer them to be safe.
 
 
 -- | Check that the safe imports of the module being compiled are valid.
@@ -772,21 +792,24 @@ hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
 hscCheckSafeImports tcg_env = do
     dflags   <- getDynFlags
     tcg_env' <- checkSafeImports dflags tcg_env
-    case safeLanguageOn dflags of
-        True -> do
-            -- XSafe: we nuke user written RULES
-            logWarnings $ warns dflags (tcg_rules tcg_env')
-            return tcg_env' { tcg_rules = [] }
-        False
-              -- SafeInferred: user defined RULES, so not safe
-            | safeInferOn dflags && not (null $ tcg_rules tcg_env')
-            -> markUnsafe tcg_env' $ warns dflags (tcg_rules tcg_env')
-
-              -- Trustworthy OR SafeInferred: with no RULES
-            | otherwise
-            -> return tcg_env'
+    checkRULES dflags tcg_env'
 
   where
+    checkRULES dflags tcg_env' = do
+      case safeLanguageOn dflags of
+          True -> do
+              -- XSafe: we nuke user written RULES
+              logWarnings $ warns dflags (tcg_rules tcg_env')
+              return tcg_env' { tcg_rules = [] }
+          False
+                -- SafeInferred: user defined RULES, so not safe
+              | safeInferOn dflags && not (null $ tcg_rules tcg_env')
+              -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
+
+                -- Trustworthy OR SafeInferred: with no RULES
+              | otherwise
+              -> return tcg_env'
+
     warns dflags rules = listToBag $ map (warnRules dflags) rules
     warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
         mkPlainWarnMsg dflags loc $
@@ -808,51 +831,55 @@ hscCheckSafeImports tcg_env = do
 checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
 checkSafeImports dflags tcg_env
     = do
+        imps <- mapM condense imports'
+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
+
         -- We want to use the warning state specifically for detecting if safe
         -- inference has failed, so store and clear any existing warnings.
         oldErrs <- getWarnings
         clearWarnings
 
-        imps <- mapM condense imports'
-        pkgs <- mapM checkSafe imps
-
-        -- grab any safe haskell specific errors and restore old warnings
-        errs <- getWarnings
+        -- Check safe imports are correct
+        safePkgs <- mapM checkSafe safeImps
+        safeErrs <- getWarnings
         clearWarnings
-        logWarnings oldErrs
 
+        -- Check non-safe imports are correct if inferring safety
         -- See the Note [Safe Haskell Inference]
-        case (not $ isEmptyBag errs) of
-
-            -- We have errors!
-            True ->
-                -- did we fail safe inference or fail -XSafe?
-                case safeInferOn dflags of
-                    True  -> markUnsafe tcg_env errs
-                    False -> liftIO . throwIO . mkSrcErr $ errs
-
-            -- All good matey!
-            False -> do
-                when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs
-                -- add in trusted package requirements for this module
-                let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
-                return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
+        (infErrs, infPkgs) <- case (safeInferOn dflags) of
+          False -> return (emptyBag, [])
+          True -> do infPkgs <- mapM checkSafe regImps
+                     infErrs <- getWarnings
+                     clearWarnings
+                     return (infErrs, infPkgs)
+
+        -- restore old errors
+        logWarnings oldErrs
+
+        case (isEmptyBag safeErrs) of
+          -- Failed safe check
+          False -> liftIO . throwIO . mkSrcErr $ safeErrs
+
+          -- Passed safe check
+          True -> do
+            let infPassed = isEmptyBag infErrs
+            tcg_env' <- case (not infPassed) of
+              True  -> markUnsafeInfer tcg_env infErrs
+              False -> return tcg_env
+            when (packageTrustOn dflags) $ checkPkgTrust dflags pkgReqs
+            let newTrust = pkgTrustReqs safePkgs infPkgs infPassed
+            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
 
   where
-    imp_info = tcg_imports tcg_env     -- ImportAvails
-    imports  = imp_mods imp_info       -- ImportedMods
+    impInfo  = tcg_imports tcg_env     -- ImportAvails
+    imports  = imp_mods impInfo        -- ImportedMods
     imports' = moduleEnvToList imports -- (Module, [ImportedModsVal])
-    pkg_reqs = imp_trust_pkgs imp_info -- [PackageKey]
+    pkgReqs  = imp_trust_pkgs impInfo  -- [PackageKey]
 
     condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
     condense (_, [])   = panic "HscMain.condense: Pattern match failure!"
     condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs
-                            -- we turn all imports into safe ones when
-                            -- inference mode is on.
-                            let s' = if safeInferOn dflags &&
-                                        safeHaskell dflags == Sf_None
-                                        then True else s
-                            return (m, l, s')
+                            return (m, l, s)
 
     -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
     cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
@@ -865,8 +892,17 @@ checkSafeImports dflags tcg_env
         = return v1
 
     -- easier interface to work with
-    checkSafe (_, _, False) = return Nothing
-    checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l
+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
+
+    -- what pkg's to add to our trust requirements
+    pkgTrustReqs req inf infPassed | safeInferOn dflags
+                                  && safeHaskell dflags == Sf_None && infPassed
+                                   = emptyImportAvails {
+                                       imp_trust_pkgs = catMaybes req ++ catMaybes inf
+                                   }
+    pkgTrustReqs _   _ _ | safeHaskell dflags == Sf_Unsafe
+                         = emptyImportAvails
+    pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req }
 
 -- | Check that a module is safe to import.
 --
@@ -1000,11 +1036,16 @@ checkPkgTrust dflags pkgs =
 
 -- | Set module to unsafe and (potentially) wipe trust information.
 --
--- Make sure to call this method to set a module to inferred unsafe,
--- it should be a central and single failure method. We only wipe the trust
--- information when we aren't in a specific Safe Haskell mode.
-markUnsafe :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
-markUnsafe tcg_env whyUnsafe = do
+-- Make sure to call this method to set a module to inferred unsafe, it should
+-- be a central and single failure method. We only wipe the trust information
+-- when we aren't in a specific Safe Haskell mode.
+--
+-- While we only use this for recording that a module was inferred unsafe, we
+-- may call it on modules using Trustworthy or Unsafe flags so as to allow
+-- warning flags for safety to function correctly. See Note [Safe Haskell
+-- Inference].
+markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
+markUnsafeInfer tcg_env whyUnsafe = do
     dflags <- getDynFlags
 
     when (wopt Opt_WarnUnsafe dflags)
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 3f2bf1680b..b94ea65a65 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -75,6 +75,25 @@ instance Outputable SourcePackageId where
 instance Outputable PackageName where
   ppr (PackageName str) = ftext str
 
+-- | Pretty-print an 'ExposedModule' in the same format used by the textual
+-- installed package database.
+pprExposedModule :: (Outputable a, Outputable b) => ExposedModule a b -> SDoc
+pprExposedModule (ExposedModule exposedName exposedReexport exposedSignature) =
+    sep [ ppr exposedName
+        , case exposedReexport of
+            Just m -> sep [text "from", pprOriginalModule m]
+            Nothing -> empty
+        , case exposedSignature of
+            Just m -> sep [text "is", pprOriginalModule m]
+            Nothing -> empty
+        ]
+
+-- | Pretty-print an 'OriginalModule' in the same format used by the textual
+-- installed package database.
+pprOriginalModule :: (Outputable a, Outputable b) => OriginalModule a b -> SDoc
+pprOriginalModule (OriginalModule originalPackageId originalModuleName) =
+    ppr originalPackageId <> char ':' <> ppr originalModuleName
+
 defaultPackageConfig :: PackageConfig
 defaultPackageConfig = emptyInstalledPackageInfo
 
@@ -101,9 +120,11 @@ pprPackageConfig InstalledPackageInfo {..} =
       field "id"                   (ppr installedPackageId),
       field "key"                  (ppr packageKey),
       field "exposed"              (ppr exposed),
-      field "exposed-modules"      (fsep (map ppr exposedModules)),
+      field "exposed-modules"
+        (if all isExposedModule exposedModules
+           then fsep (map pprExposedModule exposedModules)
+           else pprWithCommas pprExposedModule exposedModules),
       field "hidden-modules"       (fsep (map ppr hiddenModules)),
-      field "reexported-modules"   (fsep (map ppr haddockHTMLs)),
       field "trusted"              (ppr trusted),
       field "import-dirs"          (fsep (map text importDirs)),
       field "library-dirs"         (fsep (map text libraryDirs)),
@@ -122,6 +143,8 @@ pprPackageConfig InstalledPackageInfo {..} =
     ]
   where
     field name body = text name <> colon <+> nest 4 body
+    isExposedModule (ExposedModule _ Nothing Nothing) = True
+    isExposedModule _ = False
 
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index a308a990d1..519353e0bb 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -35,7 +35,6 @@ module Packages (
 
         collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
         packageHsLibs,
-        ModuleExport(..),
 
         -- * Utils
         packageKeyPackageIdString,
@@ -211,17 +210,6 @@ originEmpty :: ModuleOrigin -> Bool
 originEmpty (ModOrigin Nothing [] [] False) = True
 originEmpty _ = False
 
--- | When we do a plain lookup (e.g. for an import), initially, all we want
--- to know is if we can find it or not (and if we do and it's a reexport,
--- what the real name is).  If the find fails, we'll want to investigate more
--- to give a good error message.
-data SimpleModuleConf =
-    SModConf Module PackageConfig ModuleOrigin
-  | SModConfAmbiguous
-
--- | 'UniqFM' map from 'ModuleName'
-type ModuleNameMap = UniqFM
-
 -- | 'UniqFM' map from 'PackageKey'
 type PackageKeyMap = UniqFM
 
@@ -253,10 +241,6 @@ data PackageState = PackageState {
   -- is always mentioned before the packages it depends on.
   preloadPackages      :: [PackageKey],
 
-  -- | This is a simplified map from 'ModuleName' to original 'Module' and
-  -- package configuration providing it.
-  moduleToPkgConf       :: ModuleNameMap SimpleModuleConf,
-
   -- | This is a full map from 'ModuleName' to all modules which may possibly
   -- be providing it.  These providers may be hidden (but we'll still want
   -- to report them in error messages), or it may be an ambiguous import.
@@ -997,7 +981,6 @@ mkPackageState dflags pkgs0 preload0 this_package = do
   let pstate = PackageState{
     preloadPackages     = dep_preload,
     pkgIdMap            = pkg_db,
-    moduleToPkgConf     = mkModuleToPkgConf dflags pkg_db ipid_map vis_map,
     moduleToPkgConfAll  = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
     installedPackageIdMap = ipid_map
     }
@@ -1047,16 +1030,17 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
                             ppr orig <+> text "in package" <+> ppr pk)))
 
     es :: Bool -> [(ModuleName, e)]
-    es e =
-     [(m, sing pk  m  pkg  (fromExposedModules e)) | m <- exposed_mods] ++
-     [(m, sing pk' m' pkg' (fromReexportedModules e pkg))
-     | ModuleExport {
-         exportModuleName         = m,
-         exportOriginalPackageId  = ipid',
-         exportOriginalModuleName = m'
-       } <- reexported_mods
-     , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
-           pkg' = pkg_lookup pk' ]
+    es e = do
+     -- TODO: signature support
+     ExposedModule m exposedReexport _exposedSignature <- exposed_mods
+     let (pk', m', pkg', origin') =
+          case exposedReexport of
+           Nothing -> (pk, m, pkg, fromExposedModules e)
+           Just (OriginalModule ipid' m') ->
+            let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
+                pkg' = pkg_lookup pk'
+            in (pk', m', pkg', fromReexportedModules e pkg')
+     return (m, sing pk' m' pkg' origin')
 
     esmap :: UniqFM e
     esmap = listToUFM (es False) -- parameter here doesn't matter, orig will
@@ -1068,32 +1052,8 @@ mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
     pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
 
     exposed_mods = exposedModules pkg
-    reexported_mods = reexportedModules pkg
     hidden_mods = hiddenModules pkg
 
--- | This is a quick and efficient module map, which only contains an entry
--- if it is specified unambiguously.
-mkModuleToPkgConf
-  :: DynFlags
-  -> PackageConfigMap
-  -> InstalledPackageIdMap
-  -> VisibilityMap
-  -> ModuleNameMap SimpleModuleConf
-mkModuleToPkgConf =
-  mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo
-    where emptyMap = emptyUFM
-          sing pk m pkg = SModConf (mkModule pk m) pkg
-          -- NB: don't put hidden entries in the map, they're not valid!
-          addListTo m xs = addListToUFM_C merge m (filter isVisible xs)
-          isVisible (_, SModConf _ _ o) = originVisible o
-          isVisible (_, SModConfAmbiguous) = False
-          merge (SModConf m pkg o) (SModConf m' _ o')
-              | m == m' = SModConf m pkg (o `mappend` o')
-              | otherwise = SModConfAmbiguous
-          merge _ _ = SModConfAmbiguous
-          setOrigins (SModConf m pkg _) os = SModConf m pkg os
-          setOrigins SModConfAmbiguous _ = SModConfAmbiguous
-
 -- | This is a slow and complete map, which includes information about
 -- everything, including hidden modules
 mkModuleToPkgConfAll
@@ -1241,17 +1201,11 @@ lookupModuleWithSuggestions :: DynFlags
                             -> Maybe FastString
                             -> LookupResult
 lookupModuleWithSuggestions dflags m mb_pn
-  = case lookupUFM (moduleToPkgConf pkg_state) m of
-     Just (SModConf m pkg o) | matches mb_pn pkg o ->
-        ASSERT( originVisible o ) LookupFound m pkg
-     _ -> case Map.lookup m (moduleToPkgConfAll pkg_state) of
+  = case Map.lookup m (moduleToPkgConfAll pkg_state) of
         Nothing -> LookupNotFound suggestions
         Just xs ->
           case foldl' classify ([],[],[]) (Map.toList xs) of
             ([], [], []) -> LookupNotFound suggestions
-            -- NB: Yes, we have to check this case too, since package qualified
-            -- imports could cause the main lookup to fail due to ambiguity,
-            -- but the second lookup to succeed.
             (_, _, [(m, _)])             -> LookupFound m (mod_pkg m)
             (_, _, exposed@(_:_))        -> LookupMultiple exposed
             (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
@@ -1269,9 +1223,6 @@ lookupModuleWithSuggestions dflags m mb_pn
     pkg_state = pkgState dflags
     mod_pkg = pkg_lookup . modulePackageKey
 
-    matches Nothing _ _ = True -- shortcut for efficiency
-    matches mb_pn pkg o = originVisible (filterOrigin mb_pn pkg o)
-
     -- Filters out origins which are not associated with the given package
     -- qualifier.  No-op if there is no package qualifier.  Test if this
     -- excluded all origins with 'originEmpty'.
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index a975fdd5ac..b7a867d718 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -421,7 +421,7 @@ lookup_aux_id :: TypeEnv -> Var -> Id
 lookup_aux_id type_env id
   = case lookupTypeEnv type_env (idName id) of
         Just (AnId id') -> id'
-        _other          -> pprPanic "lookup_axu_id" (ppr id)
+        _other          -> pprPanic "lookup_aux_id" (ppr id)
 \end{code}
 
 
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index abd87ed087..a4115a0b6d 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -391,6 +391,21 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
                        ADC II32 (OpReg r2hi) (OpReg rhi) ]
    return (ChildCode64 code rlo)
 
+iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
+                       SUB II32 (OpReg r2lo) (OpReg rlo),
+                       MOV II32 (OpReg r1hi) (OpReg rhi),
+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]
+   return (ChildCode64 code rlo)
+
 iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
      fn <- getAnyReg expr
      r_dst_lo <-  getNewRegNat II32
@@ -1272,24 +1287,23 @@ getCondCode (CmmMachOp mop [x, y])
       MO_F_Lt W64 -> condFltCode LTT x y
       MO_F_Le W64 -> condFltCode LE  x y
 
-      MO_Eq _     -> condIntCode EQQ x y
-      MO_Ne _     -> condIntCode NE  x y
-
-      MO_S_Gt _   -> condIntCode GTT x y
-      MO_S_Ge _   -> condIntCode GE  x y
-      MO_S_Lt _   -> condIntCode LTT x y
-      MO_S_Le _   -> condIntCode LE  x y
-
-      MO_U_Gt _ -> condIntCode GU  x y
-      MO_U_Ge _ -> condIntCode GEU x y
-      MO_U_Lt _ -> condIntCode LU  x y
-      MO_U_Le _ -> condIntCode LEU x y
-
-      _other -> pprPanic "getCondCode(x86,x86_64)" (ppr (CmmMachOp mop [x,y]))
+      _ -> condIntCode (machOpToCond mop) x y
 
 getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other)
 
-
+machOpToCond :: MachOp -> Cond
+machOpToCond mo = case mo of
+  MO_Eq _   -> EQQ
+  MO_Ne _   -> NE
+  MO_S_Gt _ -> GTT
+  MO_S_Ge _ -> GE
+  MO_S_Lt _ -> LTT
+  MO_S_Le _ -> LE
+  MO_U_Gt _ -> GU
+  MO_U_Ge _ -> GEU
+  MO_U_Lt _ -> LU
+  MO_U_Le _ -> LEU
+  _other -> pprPanic "machOpToCond" (pprMachOp mo)
 
 
 -- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
@@ -1538,7 +1552,31 @@ genCondJump
     -> CmmExpr      -- the condition on which to branch
     -> NatM InstrBlock
 
-genCondJump id bool = do
+genCondJump id expr = do
+  is32Bit <- is32BitPlatform
+  genCondJump' is32Bit id expr
+
+genCondJump' :: Bool -> BlockId -> CmmExpr -> NatM InstrBlock
+
+-- 64-bit integer comparisons on 32-bit
+genCondJump' is32Bit true (CmmMachOp mop [e1,e2])
+  | is32Bit, Just W64 <- maybeIntComparison mop = do
+  ChildCode64 code1 r1_lo <- iselExpr64 e1
+  ChildCode64 code2 r2_lo <- iselExpr64 e2
+  let r1_hi = getHiVRegFromLo r1_lo
+      r2_hi = getHiVRegFromLo r2_lo
+      cond = machOpToCond mop
+      Just cond' = maybeFlipCond cond
+  false <- getBlockIdNat
+  return $ code1 `appOL` code2 `appOL` toOL [
+    CMP II32 (OpReg r2_hi) (OpReg r1_hi),
+    JXX cond true,
+    JXX cond' false,
+    CMP II32 (OpReg r2_lo) (OpReg r1_lo),
+    JXX cond true,
+    NEWBLOCK false ]
+
+genCondJump' _ id bool = do
   CondCode is_float cond cond_code <- getCondCode bool
   use_sse2 <- sse2Enabled
   if not is_float || not use_sse2
@@ -1569,7 +1607,6 @@ genCondJump id bool = do
                 ]
         return (cond_code `appOL` code)
 
-
 -- -----------------------------------------------------------------------------
 --  Generating C calls
 
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 2f6196227b..0d85376868 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -196,6 +196,7 @@ data Instr
         | ADD         Size Operand Operand
         | ADC         Size Operand Operand
         | SUB         Size Operand Operand
+        | SBB         Size Operand Operand
 
         | MUL         Size Operand Operand
         | MUL2        Size Operand              -- %edx:%eax = operand * %rax
@@ -365,6 +366,7 @@ x86_regUsageOfInstr platform instr
     ADD    _ src dst    -> usageRM src dst
     ADC    _ src dst    -> usageRM src dst
     SUB    _ src dst    -> usageRM src dst
+    SBB    _ src dst    -> usageRM src dst
     IMUL   _ src dst    -> usageRM src dst
     IMUL2  _ src       -> mkRU (eax:use_R src []) [eax,edx]
     MUL    _ src dst    -> usageRM src dst
@@ -543,6 +545,7 @@ x86_patchRegsOfInstr instr env
     ADD  sz src dst     -> patch2 (ADD  sz) src dst
     ADC  sz src dst     -> patch2 (ADC  sz) src dst
     SUB  sz src dst     -> patch2 (SUB  sz) src dst
+    SBB  sz src dst     -> patch2 (SBB  sz) src dst
     IMUL sz src dst     -> patch2 (IMUL sz) src dst
     IMUL2 sz src        -> patch1 (IMUL2 sz) src
     MUL sz src dst      -> patch2 (MUL sz) src dst
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index cc39557f1d..2b3711751c 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -570,11 +570,10 @@ pprInstr (ADD size (OpImm (ImmInt (-1))) dst)
   = pprSizeOp (sLit "dec") size dst
 pprInstr (ADD size (OpImm (ImmInt 1)) dst)
   = pprSizeOp (sLit "inc") size dst
-pprInstr (ADD size src dst)
-  = pprSizeOpOp (sLit "add") size src dst
-pprInstr (ADC size src dst)
-  = pprSizeOpOp (sLit "adc") size src dst
+pprInstr (ADD size src dst) = pprSizeOpOp (sLit "add") size src dst
+pprInstr (ADC size src dst) = pprSizeOpOp (sLit "adc") size src dst
 pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst
+pprInstr (SBB size src dst) = pprSizeOpOp (sLit "sbb") size src dst
 pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2
 
 pprInstr (ADD_CC size src dst)
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 2fed8dd869..7098504d85 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -357,6 +357,7 @@ basicKnownKeyNames
         , ghciIoClassName, ghciStepIoMName
     ] ++ case cIntegerLibraryType of
            IntegerGMP    -> [integerSDataConName]
+           IntegerGMP2   -> [integerSDataConName]
            IntegerSimple -> []
 
 genericTyConNames :: [Name]
@@ -937,6 +938,7 @@ integerTyConName      = tcQual  gHC_INTEGER_TYPE (fsLit "Integer")           int
 integerSDataConName   = conName gHC_INTEGER_TYPE (fsLit n)                   integerSDataConKey
   where n = case cIntegerLibraryType of
             IntegerGMP    -> "S#"
+            IntegerGMP2   -> "S#"
             IntegerSimple -> panic "integerSDataConName evaluated for integer-simple"
 mkIntegerName         = varQual gHC_INTEGER_TYPE (fsLit "mkInteger")         mkIntegerIdKey
 integerToWord64Name   = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64")   integerToWord64IdKey
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index e33ed15808..0a73585976 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -309,9 +309,21 @@ lookupTopBndrRn_maybe rdr_name
 
 
 -----------------------------------------------
+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
+-- This adds an error if the name cannot be found.
 lookupExactOcc :: Name -> RnM Name
--- See Note [Looking up Exact RdrNames]
 lookupExactOcc name
+  = do { result <- lookupExactOcc_either name
+       ; case result of
+           Left err -> do { addErr err
+                          ; return name }
+           Right name' -> return name' }
+
+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
+-- This never adds an error, but it may return one.
+lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)
+-- See Note [Looking up Exact RdrNames]
+lookupExactOcc_either name
   | Just thing <- wiredInNameTyThing_maybe name
   , Just tycon <- case thing of
                     ATyCon tc                 -> Just tc
@@ -319,10 +331,10 @@ lookupExactOcc name
                     _                         -> Nothing
   , isTupleTyCon tycon
   = do { checkTupSize (tyConArity tycon)
-       ; return name }
+       ; return (Right name) }
 
   | isExternalName name
-  = return name
+  = return (Right name)
 
   | otherwise
   = do { env <- getGlobalRdrEnv
@@ -337,23 +349,23 @@ lookupExactOcc name
        ; case gres of
            []    -> -- See Note [Splicing Exact names]
                     do { lcl_env <- getLocalRdrEnv
-                       ; unless (name `inLocalRdrEnvScope` lcl_env) $
+                       ; if name `inLocalRdrEnvScope` lcl_env
+                         then return (Right name)
+                         else
 #ifdef GHCI
                          do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
                             ; th_topnames <- readTcRef th_topnames_var
-                            ; unless (name `elemNameSet` th_topnames)
-                                     (addErr exact_nm_err)
+                            ; if name `elemNameSet` th_topnames
+                              then return (Right name)
+                              else return (Left exact_nm_err)
                             }
 #else /* !GHCI */
-                         addErr exact_nm_err
+                         return (Left exact_nm_err)
 #endif /* !GHCI */
-                       ; return name
                        }
 
-           [gre]   -> return (gre_name gre)
-           (gre:_) -> do {addErr dup_nm_err
-                         ; return (gre_name gre)
-                         }
+           [gre]   -> return (Right (gre_name gre))
+           _       -> return (Left dup_nm_err)
            -- We can get more than one GRE here, if there are multiple 
            -- bindings for the same name. Sometimes they are caught later
            -- by findLocalDupsRdrEnv, like in this example (Trac #8932):
@@ -1034,10 +1046,11 @@ lookupBindGroupOcc :: HsSigCtxt
 -- See Note [Looking up signature names]
 lookupBindGroupOcc ctxt what rdr_name
   | Just n <- isExact_maybe rdr_name
-  = do { n' <- lookupExactOcc n
-       ; return (Right n') }  -- Maybe we should check the side conditions
-                              -- but it's a pain, and Exact things only show
-                              -- up when you know what you are doing
+  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;
+                              -- see Note [dataTcOccs and Exact Names]
+      -- Maybe we should check the side conditions
+      -- but it's a pain, and Exact things only show
+      -- up when you know what you are doing
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
   = do { n' <- lookupOrig rdr_mod rdr_occ
@@ -1114,10 +1127,8 @@ lookupLocalTcNames ctxt what rdr_name
 dataTcOccs :: RdrName -> [RdrName]
 -- Return both the given name and the same name promoted to the TcClsName
 -- namespace.  This is useful when we aren't sure which we are looking at.
+-- See also Note [dataTcOccs and Exact Names]
 dataTcOccs rdr_name
-  | Just n <- isExact_maybe rdr_name
-  , not (isBuiltInSyntax n)   -- See Note [dataTcOccs and Exact Names]
-  = [rdr_name]
   | isDataOcc occ || isVarOcc occ
   = [rdr_name, rdr_name_tc]
   | otherwise
@@ -1130,8 +1141,12 @@ dataTcOccs rdr_name
 Note [dataTcOccs and Exact Names]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Exact RdrNames can occur in code generated by Template Haskell, and generally
-those references are, well, exact, so it's wrong to return the TyClsName too.
-But there is an awkward exception for built-in syntax. Example in GHCi
+those references are, well, exact. However, the TH `Name` type isn't expressive
+enough to always track the correct namespace information, so we sometimes get
+the right Unique but wrong namespace. Thus, we still have to do the double-lookup
+for Exact RdrNames.
+
+There is also an awkward situation for built-in syntax. Example in GHCi
    :info []
 This parses as the Exact RdrName for nilDataCon, but we also want
 the list type constructor.
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 8aed1657be..c2af40703d 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -16,7 +16,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
-import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWrapper )
+import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynWorker )
 
 import DynFlags
 import HsSyn
@@ -320,8 +320,8 @@ tcValBinds top_lvl binds sigs thing_inside
             { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
                    { thing <- thing_inside
                      -- See Note [Pattern synonym wrappers don't yield dependencies]
-                   ; patsyn_wrappers <- mapM tcPatSynWrapper patsyns
-                   ; let extra_binds = [ (NonRecursive, wrapper) | wrapper <- patsyn_wrappers ]
+                   ; patsyn_workers <- mapM tcPatSynWorker patsyns
+                   ; let extra_binds = [ (NonRecursive, worker) | worker <- patsyn_workers ]
                    ; return (extra_binds, thing) }
              ; return (binds' ++ extra_binds', thing) }}
   where
@@ -424,7 +424,7 @@ tc_single _top_lvl _sig_fn _prag_fn (L _ (PatSynBind psb)) thing_inside
 
        ; let tything = AConLike (PatSynCon pat_syn)
              implicit_ids = (patSynMatcher pat_syn) :
-                            (maybeToList (patSynWrapper pat_syn))
+                            (maybeToList (patSynWorker pat_syn))
 
        ; thing <- tcExtendGlobalEnv [tything] $
                   tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index bcd6bfdf82..0ef74a1f5a 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -224,7 +224,8 @@ tcLookupInstance cls tys
       where
         extractTyVar (TyVarTy tv) = tv
         extractTyVar _            = panic "TcEnv.tcLookupInstance: extractTyVar"
-    
+
+    -- NB: duplicated to prevent circular dependence on Inst
     tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
                        ; return (eps_inst_env eps, tcg_inst_env env) 
                        }
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index deda6137d0..a242ed77d2 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -124,16 +124,9 @@ tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
 
 tcInferRhoNC (L loc expr)
   = setSrcSpan loc $
-    do { (expr', rho) <- tcInfExpr expr
+    do { (expr', rho) <- tcInfer (tcExpr expr)
        ; return (L loc expr', rho) }
 
-tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType)
-tcInfExpr (HsVar f)     = tcInferId f
-tcInfExpr (HsPar e)     = do { (e', ty) <- tcInferRhoNC e
-                             ; return (HsPar e', ty) }
-tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2]
-tcInfExpr e             = tcInfer (tcExpr e)
-
 tcHole :: OccName -> TcRhoType -> TcM (HsExpr TcId)
 tcHole occ res_ty
  = do { ty <- newFlexiTyVarTy liftedTypeKind
@@ -326,13 +319,15 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
        -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
        --    (which gives a seg fault)
        -- We do this by unifying with a MetaTv; but of course
-       -- it must allow foralls in the type it unifies with (hence PolyTv)!
+       -- it must allow foralls in the type it unifies with (hence ReturnTv)!
        --
        -- The result type can have any kind (Trac #8739),
        -- so we can just use res_ty
 
        -- ($) :: forall (a:*) (b:Open). (a->b) -> a -> b
-       ; a_ty <- newPolyFlexiTyVarTy
+       ; a_tv <- newReturnTyVar liftedTypeKind
+       ; let a_ty = mkTyVarTy a_tv
+
        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
 
        ; co_a   <- unifyType arg2_ty   a_ty      -- arg2 ~ a
@@ -937,23 +932,6 @@ mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
                      , ptext (sLit "is applied to")]
 
 ----------------
-tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
-           -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args
-
-tcInferApp (L _ (HsPar e))     args = tcInferApp e args
-tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args)
-tcInferApp fun args
-  = -- Very like the tcApp version, except that there is
-    -- no expected result type passed in
-    do  { (fun1, fun_tau) <- tcInferFun fun
-        ; (co_fun, expected_arg_tys, actual_res_ty)
-              <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
-        ; args1 <- tcArgs fun args expected_arg_tys
-        ; let fun2 = mkLHsWrapCo co_fun fun1
-              app  = foldl mkHsApp fun2 args1
-        ; return (unLoc app, actual_res_ty) }
-
-----------------
 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 -- Infer and instantiate the type of a function
 tcInferFun (L loc (HsVar name))
diff --git a/compiler/typecheck/TcFlatten.lhs b/compiler/typecheck/TcFlatten.lhs
index 3ee4d593f6..2e9c6eb0a9 100644
--- a/compiler/typecheck/TcFlatten.lhs
+++ b/compiler/typecheck/TcFlatten.lhs
@@ -601,6 +601,9 @@ goals.  But to be honest I'm not absolutely certain, so I am leaving
 FM_Avoid in the code base.  What I'm removing is the unique place
 where it is *used*, namely in TcCanonical.canEqTyVar.
 
+See also Note [Conservative unification check] in TcUnify, which gives
+other examples where lazy flattening caused problems.
+
 Bottom line: FM_Avoid is unused for now (Nov 14).
 Note: T5321Fun got faster when I disabled FM_Avoid
       T5837 did too, but it's pathalogical anyway
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index ddb2e6531a..b6c0da1e8b 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -1009,23 +1009,28 @@ superclass is bottom when it should not be.
 
 Consider the following (extreme) situation:
         class C a => D a where ...
-        instance D [a] => D [a] where ...
+        instance D [a] => D [a] where ...   (dfunD)
+        instance C [a] => C [a] where ...   (dfunC)
 Although this looks wrong (assume D [a] to prove D [a]), it is only a
 more extreme case of what happens with recursive dictionaries, and it
 can, just about, make sense because the methods do some work before
 recursing.
 
-To implement the dfun we must generate code for the superclass C [a],
+To implement the dfunD we must generate code for the superclass C [a],
 which we had better not get by superclass selection from the supplied
 argument:
-       dfun :: forall a. D [a] -> D [a]
-       dfun = \d::D [a] -> MkD (scsel d) ..
+       dfunD :: forall a. D [a] -> D [a]
+       dfunD = \d::D [a] -> MkD (scsel d) ..
 
 Otherwise if we later encounter a situation where
 we have a [Wanted] dw::D [a] we might solve it thus:
-     dw := dfun dw
+     dw := dfunD dw
 Which is all fine except that now ** the superclass C is bottom **!
 
+The instance we want is:
+       dfunD :: forall a. D [a] -> D [a]
+       dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
+
       THE SOLUTION
 
 Our solution to this problem "silent superclass arguments".  We pass
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 811b16a616..2e5618ea78 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1197,56 +1197,69 @@ Consider generating the superclasses of the instance declaration
          instance Foo a => Foo [a]
 
 So our problem is this
-    d0 :_g Foo t
-    d1 :_w Data Maybe [t]
+    [G] d0 : Foo t
+    [W] d1 : Data Maybe [t]   -- Desired superclass
 
 We may add the given in the inert set, along with its superclasses
 [assuming we don't fail because there is a matching instance, see
  topReactionsStage, given case ]
   Inert:
-    d0 :_g Foo t
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
   WorkList
-    d01 :_g Data Maybe t  -- d2 := EvDictSuperClass d0 0
-    d1 :_w Data Maybe [t]
-Then d2 can readily enter the inert, and we also do solving of the wanted
+    [W] d1 : Data Maybe [t]
+
+Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3
   Inert:
-    d0 :_g Foo t
-    d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
   WorkList
-    d2 :_w Sat (Maybe [t])
-    d3 :_w Data Maybe t
-    d01 :_g Data Maybe t
-Now, we may simplify d2 more:
+    [W] d2 : Sat (Maybe [t])
+    [W] d3 : Data Maybe t
+
+Now, we may simplify d2 using dfunSat; d2 := dfunSat d4
   Inert:
-      d0 :_g Foo t
-      d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3
-      d1 :_g Data Maybe [t]
-      d2 :_g Sat (Maybe [t])          d2 := dfunSat d4
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
   WorkList:
-      d3 :_w Data Maybe t
-      d4 :_w Foo [t]
-      d01 :_g Data Maybe t
+    [W] d3 : Data Maybe t
+    [W] d4 : Foo [t]
 
-Now, we can just solve d3.
+Now, we can just solve d3 from d01; d3 := d01
   Inert
-      d0 :_g Foo t
-      d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3
-      d2 :_g Sat (Maybe [t])          d2 := dfunSat d4
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
   WorkList
-      d4 :_w Foo [t]
-      d01 :_g Data Maybe t
-And now we can simplify d4 again, but since it has superclasses we *add* them to the worklist:
+    [W] d4 : Foo [t]
+
+Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5
   Inert
-      d0 :_g Foo t
-      d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3
-      d2 :_g Sat (Maybe [t])          d2 := dfunSat d4
-      d4 :_g Foo [t]                  d4 := dfunFoo2 d5
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
+        d4 : Foo [t]
   WorkList:
-      d5 :_w Foo t
-      d6 :_g Data Maybe [t]           d6 := EvDictSuperClass d4 0
-      d01 :_g Data Maybe t
-Now, d5 can be solved! (and its superclass enter scope)
-  Inert
+    [W] d5 : Foo t
+
+Now, d5 can be solved! d5 := d0
+
+Result
+   d1 := dfunData2 d2 d3
+   d2 := dfunSat d4
+   d3 := d01
+   d4 := dfunFoo2 d5
+   d5 := d0
+
       d0 :_g Foo t
       d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3
       d2 :_g Sat (Maybe [t])          d2 := dfunSat d4
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index d6f37c8f96..c78c125bf1 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -19,12 +19,12 @@ module TcMType (
   newFlexiTyVar,
   newFlexiTyVarTy,              -- Kind -> TcM TcType
   newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]
-  newPolyFlexiTyVarTy,
+  newReturnTyVar,
   newMetaKindVar, newMetaKindVars,
   mkTcTyVarName, cloneMetaTyVar,
 
   newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
-  newMetaDetails, isFilledMetaTyVar, isFlexiMetaTyVar,
+  newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar,
 
   --------------------------------
   -- Creating new evidence variables
@@ -311,7 +311,7 @@ newMetaTyVar meta_info kind
   = do  { uniq <- newUnique
         ; let name = mkTcTyVarName uniq s
               s = case meta_info of
-                        PolyTv     -> fsLit "s"
+                        ReturnTv   -> fsLit "r"
                         TauTv      -> fsLit "t"
                         FlatMetaTv -> fsLit "fmv"
                         SigTv      -> fsLit "a"
@@ -363,9 +363,9 @@ isFilledMetaTyVar tv
         ; return (isIndirect details) }
   | otherwise = return False
 
-isFlexiMetaTyVar :: TyVar -> TcM Bool
+isUnfilledMetaTyVar :: TyVar -> TcM Bool
 -- True of a un-filled-in (Flexi) meta type variable
-isFlexiMetaTyVar tv
+isUnfilledMetaTyVar tv
   | not (isTcTyVar tv) = return False
   | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
   = do  { details <- readMutVar ref
@@ -448,9 +448,8 @@ newFlexiTyVarTy kind = do
 newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
 newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
 
-newPolyFlexiTyVarTy :: TcM TcType
-newPolyFlexiTyVarTy = do { tv <- newMetaTyVar PolyTv liftedTypeKind
-                         ; return (TyVarTy tv) }
+newReturnTyVar :: Kind -> TcM TcTyVar
+newReturnTyVar kind = newMetaTyVar ReturnTv kind
 
 tcInstTyVars :: [TKVar] -> TcM (TvSubst, [TcTyVar])
 -- Instantiate with META type variables
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index ea2dbce9d7..d6f6817cce 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -7,13 +7,14 @@
 \begin{code}
 {-# LANGUAGE CPP #-}
 
-module TcPatSyn (tcPatSynDecl, tcPatSynWrapper) where
+module TcPatSyn (tcPatSynDecl, mkPatSynWrapperId, tcPatSynWorker) where
 
 import HsSyn
 import TcPat
 import TcRnMonad
 import TcEnv
 import TcMType
+import TcIface
 import TysPrim
 import Name
 import SrcLoc
@@ -36,7 +37,7 @@ import Data.Monoid
 import Bag
 import TcEvidence
 import BuildTyCl
-import TypeRep
+import Data.Maybe
 
 #include "HsVersions.h"
 \end{code}
@@ -48,7 +49,6 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                   psb_def = lpat, psb_dir = dir }
   = do { traceTc "tcPatSynDecl {" $ ppr name $$ ppr lpat
        ; tcCheckPatSynPat lpat
-       ; 
 
        ; let (arg_names, is_infix) = case details of
                  PrefixPatSyn names      -> (map unLoc names, False)
@@ -78,6 +78,7 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
        ; req_theta  <- zonkTcThetaType req_theta
        ; pat_ty     <- zonkTcType pat_ty
        ; args       <- mapM zonkId args
+       ; let arg_tys = map varType args
 
        ; traceTc "tcPatSynDecl: ex" (ppr ex_tvs $$
                                      ppr prov_theta $$
@@ -87,7 +88,8 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                                        ppr req_dicts $$
                                        ppr ev_binds)
 
-       ; let theta = prov_theta ++ req_theta
+       ; let qtvs = univ_tvs ++ ex_tvs
+       ; let theta = req_theta ++ prov_theta
 
        ; traceTc "tcPatSynDecl: type" (ppr name $$
                                        ppr univ_tvs $$
@@ -101,17 +103,19 @@ tcPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
                                          prov_theta req_theta
                                          pat_ty
 
-       ; wrapper_id <- if isBidirectional dir
-                       then fmap Just $ mkPatSynWrapperId lname args univ_tvs ex_tvs theta pat_ty
-                       else return Nothing
+       ; wrapper_ids <- if isBidirectional dir
+                        then fmap Just $ mkPatSynWrapperIds lname
+                                           qtvs theta
+                                           arg_tys pat_ty
+                        else return Nothing
 
        ; traceTc "tcPatSynDecl }" $ ppr name
        ; let patSyn = mkPatSyn name is_infix
                         (univ_tvs, req_theta)
                         (ex_tvs, prov_theta)
-                        (map varType args)
+                        arg_tys
                         pat_ty
-                        matcher_id wrapper_id
+                        matcher_id wrapper_ids
        ; return (patSyn, matcher_bind) }
 
 \end{code}
@@ -134,7 +138,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
               ; let tv_name = mkInternalName uniq (mkTyVarOcc "r") loc
               ; return $ mkTcTyVar tv_name openTypeKind (SkolemTv False) }
        ; matcher_name <- newImplicitBinder name mkMatcherOcc
-       ; let res_ty = TyVarTy res_tv
+       ; let res_ty = mkTyVarTy res_tv
              cont_args = if null args then [voidPrimId] else args
              cont_ty = mkSigmaTy ex_tvs prov_theta $
                        mkFunTys (map varType cont_args) res_ty
@@ -149,7 +153,8 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
 
        ; scrutinee <- mkId "scrut" pat_ty
        ; cont <- mkId "cont" cont_ty
-       ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ cont_args)
+       ; let cont' = nlHsTyApps cont (map mkTyVarTy ex_tvs) $
+                     map nlHsVar (prov_dicts ++ cont_args)
        ; fail <- mkId "fail" fail_ty
        ; let fail' = nlHsApps fail [nlHsVar voidPrimId]
 
@@ -201,73 +206,69 @@ isBidirectional Unidirectional = False
 isBidirectional ImplicitBidirectional = True
 isBidirectional ExplicitBidirectional{} = True
 
-tcPatSynWrapper :: PatSynBind Name Name
+tcPatSynWorker :: PatSynBind Name Name
                 -> TcM (LHsBinds Id)
 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
-tcPatSynWrapper PSB{ psb_id = L loc name, psb_def = lpat, psb_dir = dir, psb_args = details }
+tcPatSynWorker PSB{ psb_id = lname, psb_def = lpat, psb_dir = dir, psb_args = details }
   = case dir of
     Unidirectional -> return emptyBag
     ImplicitBidirectional ->
-        do { wrapper_id <- tcLookupPatSynWrapper name
-           ; lexpr <- case tcPatToExpr (mkNameSet args) lpat of
+        do { lexpr <- case tcPatToExpr (mkNameSet args) lpat of
                   Nothing -> cannotInvertPatSynErr lpat
                   Just lexpr -> return lexpr
            ; let wrapper_args = map (noLoc . VarPat) args
-                 wrapper_lname = L (getLoc lpat) (idName wrapper_id)
                  wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
-                 wrapper_bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
-           ; mkPatSynWrapper wrapper_id wrapper_bind }
-    ExplicitBidirectional mg ->
-        do { wrapper_id <- tcLookupPatSynWrapper name
-           ; mkPatSynWrapper wrapper_id $
-               FunBind{ fun_id = L loc (idName wrapper_id)
-                      , fun_infix = False
-                      , fun_matches = mg
-                      , fun_co_fn = idHsWrapper
-                      , bind_fvs = placeHolderNamesTc
-                      , fun_tick = Nothing }}
+           ; mkPatSynWorker lname $ mkMatchGroupName Generated [wrapper_match] }
+    ExplicitBidirectional mg -> mkPatSynWorker lname mg
   where
     args = map unLoc $ case details of
         PrefixPatSyn args -> args
         InfixPatSyn arg1 arg2 -> [arg1, arg2]
 
-    tcLookupPatSynWrapper name
-      = do { patsyn <- tcLookupPatSyn name
-           ; case patSynWrapper patsyn of
-               Nothing -> panic "tcLookupPatSynWrapper"
-               Just wrapper_id -> return wrapper_id }
-
-mkPatSynWrapperId :: Located Name
-                  -> [Var] -> [TyVar] -> [TyVar] -> ThetaType -> Type
-                  -> TcM Id
-mkPatSynWrapperId (L _ name) args univ_tvs ex_tvs theta pat_ty
-  = do { let qtvs = univ_tvs ++ ex_tvs
-       ; (subst, wrapper_tvs) <- tcInstSkolTyVars qtvs
-       ; let wrapper_theta = substTheta subst theta
-             pat_ty' = substTy subst pat_ty
-             args' = map (\arg -> setVarType arg $ substTy subst (varType arg)) args
-             wrapper_tau = mkFunTys (map varType args') pat_ty'
-             wrapper_sigma = mkSigmaTy wrapper_tvs wrapper_theta wrapper_tau
-
-       ; wrapper_name <- newImplicitBinder name mkDataConWrapperOcc
-       ; return $ mkVanillaGlobal wrapper_name wrapper_sigma }
-
-mkPatSynWrapper :: Id
-                -> HsBind Name
+mkPatSynWrapperIds :: Located Name
+                   -> [TyVar] -> ThetaType -> [Type] -> Type
+                   -> TcM (Id, Id)
+mkPatSynWrapperIds lname qtvs theta arg_tys pat_ty
+  = do { worker_id <- mkPatSynWorkerId lname mkDataConWorkerOcc qtvs theta worker_arg_tys pat_ty
+       ; wrapper_id <- mkPatSynWrapperId lname qtvs theta arg_tys pat_ty worker_id
+       ; return (wrapper_id, worker_id) }
+  where
+    worker_arg_tys | need_dummy_arg = [voidPrimTy]
+                   | otherwise = arg_tys
+    need_dummy_arg = null arg_tys && isUnLiftedType pat_ty
+
+mkPatSynWorker :: Located Name
+                -> MatchGroup Name (LHsExpr Name)
                 -> TcM (LHsBinds Id)
-mkPatSynWrapper wrapper_id bind
-  = do { (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
-       ; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds
-       ; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id)
-       ; return wrapper_binds }
+mkPatSynWorker (L loc name) mg
+  = do { patsyn <- tcLookupPatSyn name
+       ; let worker_id = fromMaybe (panic "mkPatSynWrapper") $
+                         patSynWorker patsyn
+             need_dummy_arg = null (patSynArgs patsyn) && isUnLiftedType (patSynType patsyn)
+
+       ; let match_dummy = mkMatch [nlWildPatName] (noLoc $ HsLam mg) emptyLocalBinds
+             mg' | need_dummy_arg = mkMatchGroupName Generated [match_dummy]
+                 | otherwise = mg
+
+       ; let (worker_tvs, worker_theta, worker_tau) = tcSplitSigmaTy (idType worker_id)
+             bind = FunBind { fun_id = L loc (idName worker_id)
+                            , fun_infix = False
+                            , fun_matches = mg'
+                            , fun_co_fn = idHsWrapper
+                            , bind_fvs = placeHolderNamesTc
+                            , fun_tick = Nothing }
+
+             sig = TcSigInfo{ sig_id = worker_id
+                            , sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs
+                            , sig_theta = worker_theta
+                            , sig_tau = worker_tau
+                            , sig_loc = noSrcSpan
+                            }
+
+       ; (worker_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (noLoc bind)
+       ; traceTc "tcPatSynDecl worker" $ ppr worker_binds
+       ; return worker_binds }
   where
-    sig = TcSigInfo{ sig_id = wrapper_id
-                   , sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs
-                   , sig_theta = wrapper_theta
-                   , sig_tau = wrapper_tau
-                   , sig_loc = noSrcSpan
-                   }
-    (wrapper_tvs, wrapper_theta, wrapper_tau) = tcSplitSigmaTy (idType wrapper_id)
 
 \end{code}
 
diff --git a/compiler/typecheck/TcPatSyn.lhs-boot b/compiler/typecheck/TcPatSyn.lhs-boot
index 700137c16c..0e28caa6ca 100644
--- a/compiler/typecheck/TcPatSyn.lhs-boot
+++ b/compiler/typecheck/TcPatSyn.lhs-boot
@@ -10,6 +10,6 @@ import PatSyn    ( PatSyn )
 tcPatSynDecl :: PatSynBind Name Name
              -> TcM (PatSyn, LHsBinds Id)
 
-tcPatSynWrapper :: PatSynBind Name Name
-                -> TcM (LHsBinds Id)
+tcPatSynWorker :: PatSynBind Name Name
+               -> TcM (LHsBinds Id)
 \end{code}
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 02d0026bdd..a646ea445a 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -238,10 +238,7 @@ checkHsigIface' gr
         ; r <- tcLookupImported_maybe name
         ; case r of
             Failed err -> addErr err
-            Succeeded real_thing ->
-              when (not (checkBootDecl sig_thing real_thing))
-               $ addErrAt (nameSrcSpan (getName sig_thing))
-                          (bootMisMatch False real_thing sig_thing)
+            Succeeded real_thing -> checkBootDeclM False sig_thing real_thing
         }}
       where
         name          = availName sig_avail
@@ -767,9 +764,7 @@ checkHiBootIface'
         -- then compare the definitions
       | Just real_thing <- lookupTypeEnv local_type_env name,
         Just boot_thing <- mb_boot_thing
-      = when (not (checkBootDecl boot_thing real_thing))
-            $ addErrAt (nameSrcSpan (getName boot_thing))
-                       (bootMisMatch True real_thing boot_thing)
+      = checkBootDeclM True boot_thing real_thing
 
       | otherwise
       = addErrTc (missingBootThing True name "defined in")
@@ -810,11 +805,25 @@ checkHiBootIface'
 --
 -- See rnfail055 for a good test of this stuff.
 
-checkBootDecl :: TyThing -> TyThing -> Bool
+-- | Compares two things for equivalence between boot-file and normal code,
+-- reporting an error if they don't match up.
+checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
+               -> TyThing -> TyThing -> TcM ()
+checkBootDeclM is_boot boot_thing real_thing
+  = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err ->
+    addErrAt (nameSrcSpan (getName boot_thing))
+             (bootMisMatch is_boot err real_thing boot_thing)
+
+-- | Compares the two things for equivalence between boot-file and normal
+-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
+-- failure. If the difference will be apparent to the user, @Just empty@ is
+-- perfectly suitable.
+checkBootDecl :: TyThing -> TyThing -> Maybe SDoc
 
 checkBootDecl (AnId id1) (AnId id2)
   = ASSERT(id1 == id2)
-    (idType id1 `eqType` idType id2)
+    check (idType id1 `eqType` idType id2)
+          (text "The two types are different")
 
 checkBootDecl (ATyCon tc1) (ATyCon tc2)
   = checkBootTyCon tc1 tc2
@@ -822,13 +831,52 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2)
 checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
   = pprPanic "checkBootDecl" (ppr dc1)
 
-checkBootDecl _ _ = False -- probably shouldn't happen
+checkBootDecl _ _ = Just empty -- probably shouldn't happen
+
+-- | Combines two potential error messages
+andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
+Nothing `andThenCheck` msg     = msg
+msg     `andThenCheck` Nothing = msg
+Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
+infixr 0 `andThenCheck`
+
+-- | If the test in the first parameter is True, succeed with @Nothing@;
+-- otherwise, return the provided check
+checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
+checkUnless True  _ = Nothing
+checkUnless False k = k
+
+-- | Run the check provided for every pair of elements in the lists.
+-- The provided SDoc should name the element type, in the plural.
+checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
+            -> Maybe SDoc
+checkListBy check_fun as bs whats = go [] as bs
+  where
+    herald = text "The" <+> whats <+> text "do not match"
+    
+    go []   [] [] = Nothing
+    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
+    go docs (x:xs) (y:ys) = case check_fun x y of
+      Just doc -> go (doc:docs) xs ys
+      Nothing  -> go docs       xs ys
+    go _    _  _ = Just (hang (herald <> colon)
+                            2 (text "There are different numbers of" <+> whats))
+
+-- | If the test in the first parameter is True, succeed with @Nothing@;
+-- otherwise, fail with the given SDoc.
+check :: Bool -> SDoc -> Maybe SDoc
+check True  _   = Nothing
+check False doc = Just doc
+
+-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
+checkSuccess :: Maybe SDoc
+checkSuccess = Nothing
 
 ----------------
-checkBootTyCon :: TyCon -> TyCon -> Bool
+checkBootTyCon :: TyCon -> TyCon -> Maybe SDoc
 checkBootTyCon tc1 tc2
   | not (eqKind (tyConKind tc1) (tyConKind tc2))
-  = False       -- First off, check the kind
+  = Just $ text "The types have different kinds"    -- First off, check the kind
 
   | Just c1 <- tyConClass_maybe tc1
   , Just c2 <- tyConClass_maybe tc2
@@ -839,18 +887,29 @@ checkBootTyCon tc1 tc2
   , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
   = let
        eqSig (id1, def_meth1) (id2, def_meth2)
-         = idName id1 == idName id2 &&
-           eqTypeX env op_ty1 op_ty2 &&
-           def_meth1 == def_meth2
+         = check (name1 == name2)
+                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
+                  text "are different") `andThenCheck`
+           check (eqTypeX env op_ty1 op_ty2)
+                 (text "The types of" <+> pname1 <+>
+                  text "are different") `andThenCheck`
+           check (def_meth1 == def_meth2)
+                 (text "The default methods associated with" <+> pname1 <+>
+                  text "are different")
          where
+          name1 = idName id1
+          name2 = idName id2
+          pname1 = quotes (ppr name1)
+          pname2 = quotes (ppr name2)
           (_, rho_ty1) = splitForAllTys (idType id1)
           op_ty1 = funResultTy rho_ty1
           (_, rho_ty2) = splitForAllTys (idType id2)
           op_ty2 = funResultTy rho_ty2
 
        eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
-         = checkBootTyCon tc1 tc2 &&
-           eqATDef def_ats1 def_ats2
+         = checkBootTyCon tc1 tc2 `andThenCheck`
+           check (eqATDef def_ats1 def_ats2)
+                 (text "The associated type defaults differ")
 
        -- Ignore the location of the defaults
        eqATDef Nothing    Nothing    = True
@@ -861,14 +920,16 @@ checkBootTyCon tc1 tc2
          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
          eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
     in
-       roles1 == roles2 &&
-             -- Checks kind of class
-       eqListBy eqFD clas_fds1 clas_fds2 &&
-       (null sc_theta1 && null op_stuff1 && null ats1
-        ||   -- Above tests for an "abstract" class
-        eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
-        eqListBy eqSig op_stuff1 op_stuff2 &&
-        eqListBy eqAT ats1 ats2)
+    check (roles1 == roles2) roles_msg `andThenCheck`
+          -- Checks kind of class
+    check (eqListBy eqFD clas_fds1 clas_fds2)
+          (text "The functional dependencies do not match") `andThenCheck`
+    checkUnless (null sc_theta1 && null op_stuff1 && null ats1) $
+                     -- Above tests for an "abstract" class
+    check (eqListBy (eqPredX env) sc_theta1 sc_theta2)
+          (text "The class constraints do not match") `andThenCheck`
+    checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
+    checkListBy eqAT ats1 ats2 (text "associated types")
 
   | Just syn_rhs1 <- synTyConRhs_maybe tc1
   , Just syn_rhs2 <- synTyConRhs_maybe tc2
@@ -884,37 +945,61 @@ checkBootTyCon tc1 tc2
         eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
         eqSynRhs _ _ = False
     in
-    roles1 == roles2 &&
-    eqSynRhs syn_rhs1 syn_rhs2
+    check (roles1 == roles2) roles_msg `andThenCheck`
+    check (eqSynRhs syn_rhs1 syn_rhs2) empty   -- nothing interesting to say
 
   | isAlgTyCon tc1 && isAlgTyCon tc2
   , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
   = ASSERT(tc1 == tc2)
-    roles1 == roles2 &&
-    eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
-    eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
+    check (roles1 == roles2) roles_msg `andThenCheck`
+    check (eqListBy (eqPredX env)
+                     (tyConStupidTheta tc1) (tyConStupidTheta tc2))
+          (text "The datatype contexts do not match") `andThenCheck`
+    eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
 
-  | otherwise = False
+  | otherwise = Just empty   -- two very different types -- should be obvious
   where
     roles1 = tyConRoles tc1
     roles2 = tyConRoles tc2
-
-    eqAlgRhs (AbstractTyCon dis1) rhs2
-      | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
-      | otherwise = True
-    eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
-    eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
-        eqListBy eqCon (data_cons tc1) (data_cons tc2)
-    eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
+    roles_msg = text "The roles do not match." <+>
+                (text "Roles default to" <+>
+                 quotes (text "representational") <+> text "in boot files")
+
+    eqAlgRhs tc (AbstractTyCon dis1) rhs2
+      | dis1      = check (isDistinctAlgRhs rhs2)   --Check compatibility
+                          (text "The natures of the declarations for" <+>
+                           quotes (ppr tc) <+> text "are different")
+      | otherwise = checkSuccess
+    eqAlgRhs _  DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess
+    eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =
+        checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
+    eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =
         eqCon (data_con tc1) (data_con tc2)
-    eqAlgRhs _ _ = False
+    eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
+                           text "definition with a" <+> quotes (text "newtype") <+>
+                           text "definition")
 
     eqCon c1 c2
-      =  dataConName c1 == dataConName c2
-      && dataConIsInfix c1 == dataConIsInfix c2
-      && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
-      && dataConFieldLabels c1 == dataConFieldLabels c2
-      && eqType (dataConUserType c1) (dataConUserType c2)
+      =  check (name1 == name2)
+               (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
+                text "differ") `andThenCheck`
+         check (dataConIsInfix c1 == dataConIsInfix c2)
+               (text "The fixities of" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (eqListBy eqHsBang
+                         (dataConStrictMarks c1) (dataConStrictMarks c2))
+               (text "The strictness annotations for" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (dataConFieldLabels c1 == dataConFieldLabels c2)
+               (text "The record label lists for" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (eqType (dataConUserType c1) (dataConUserType c2))
+               (text "The types for" <+> pname1 <+> text "differ")
+      where
+        name1 = dataConName c1
+        name2 = dataConName c2
+        pname1 = quotes (ppr name1)
+        pname2 = quotes (ppr name2)
 
     eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
                      (CoAxiom { co_ax_branches = branches2 })
@@ -940,8 +1025,8 @@ missingBootThing is_boot name what
               <+> ptext (sLit "file, but not")
               <+> text what <+> ptext (sLit "the module")
 
-bootMisMatch :: Bool -> TyThing -> TyThing -> SDoc
-bootMisMatch is_boot real_thing boot_thing
+bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
+bootMisMatch is_boot extra_info real_thing boot_thing
   = vcat [ppr real_thing <+>
           ptext (sLit "has conflicting definitions in the module"),
           ptext (sLit "and its") <+>
@@ -951,7 +1036,8 @@ bootMisMatch is_boot real_thing boot_thing
           (if is_boot
             then ptext (sLit "Boot file:  ")
             else ptext (sLit "Hsig file: "))
-            <+> PprTyThing.pprTyThing boot_thing]
+            <+> PprTyThing.pprTyThing boot_thing,
+          extra_info]
 
 instMisMatch :: Bool -> ClsInst -> SDoc
 instMisMatch is_boot inst
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 19bd602e52..743dcbcd55 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -1251,6 +1251,9 @@ mkIfLclEnv mod loc = IfLclEnv { if_mod     = mod,
                                 if_tv_env  = emptyUFM,
                                 if_id_env  = emptyUFM }
 
+-- | Run an 'IfG' (top-level interface monad) computation inside an existing
+-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
+-- based on 'TcGblEnv'.
 initIfaceTcRn :: IfG a -> TcRn a
 initIfaceTcRn thing_inside
   = do  { tcg_env <- getGblEnv
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index cc76c03523..15be2a6212 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -148,7 +148,11 @@ import qualified Language.Haskell.TH as TH
 The monad itself has to be defined here, because it is mentioned by ErrCtxt
 
 \begin{code}
+-- | Type alias for 'IORef'; the convention is we'll use this for mutable
+-- bits of data in 'TcGblEnv' which are updated during typechecking and
+-- returned at the end.
 type TcRef a     = IORef a
+-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'?
 type TcId        = Id
 type TcIdSet     = IdSet
 
@@ -158,9 +162,19 @@ type IfM lcl  = TcRnIf IfGblEnv lcl         -- Iface stuff
 
 type IfG  = IfM ()                          -- Top level
 type IfL  = IfM IfLclEnv                    -- Nested
+
+-- | Type-checking and renaming monad: the main monad that most type-checking
+-- takes place in.  The global environment is 'TcGblEnv', which tracks
+-- all of the top-level type-checking information we've accumulated while
+-- checking a module, while the local environment is 'TcLclEnv', which
+-- tracks local information as we move inside expressions.
 type TcRn = TcRnIf TcGblEnv TcLclEnv
-type RnM  = TcRn            -- Historical
-type TcM  = TcRn            -- Historical
+
+-- | Historical "renaming monad" (now it's just 'TcRn').
+type RnM  = TcRn
+
+-- | Historical "type-checking monad" (now it's just 'TcRn').
+type TcM  = TcRn
 \end{code}
 
 Representation of type bindings to uninstantiated meta variables used during
@@ -208,12 +222,11 @@ instance ContainsDynFlags (Env gbl lcl) where
 instance ContainsModule gbl => ContainsModule (Env gbl lcl) where
     extractModule env = extractModule (env_gbl env)
 
--- TcGblEnv describes the top-level of the module at the
+-- | 'TcGblEnv' describes the top-level of the module at the
 -- point at which the typechecker is finished work.
 -- It is this structure that is handed on to the desugarer
 -- For state that needs to be updated during the typechecking
--- phase and returned at end, use a TcRef (= IORef).
-
+-- phase and returned at end, use a 'TcRef' (= 'IORef').
 data TcGblEnv
   = TcGblEnv {
         tcg_mod     :: Module,         -- ^ Module being compiled
@@ -502,8 +515,8 @@ data IfLclEnv
 %*                                                                      *
 %************************************************************************
 
-The Global-Env/Local-Env story
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [The Global-Env/Local-Env story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 During type checking, we keep in the tcg_type_env
         * All types and classes
         * All Ids derived from types and classes (constructors, selectors)
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index ea467f0ad0..f2efb2ae58 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1308,15 +1308,22 @@ reifyClass cls
   = do  { cxt <- reifyCxt theta
         ; inst_envs <- tcGetInstEnvs
         ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
-        ; ops <- mapM reify_op op_stuff
+        ; ops <- concatMapM reify_op op_stuff
         ; tvs' <- reifyTyVars tvs
         ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' ops
         ; return (TH.ClassI dec insts ) }
   where
     (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
     fds' = map reifyFunDep fds
-    reify_op (op, _) = do { ty <- reifyType (idType op)
-                          ; return (TH.SigD (reifyName op) ty) }
+    reify_op (op, def_meth)
+      = do { ty <- reifyType (idType op)
+           ; let nm' = reifyName op
+           ; case def_meth of
+                GenDefMeth gdm_nm ->
+                  do { gdm_id <- tcLookupId gdm_nm
+                     ; gdm_ty <- reifyType (idType gdm_id)
+                     ; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] }
+                _ -> return [TH.SigD nm' ty] }
 
 ------------------------------
 -- | Annotate (with TH.SigT) a type if the first parameter is True
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index a4a646c8e9..dba1be8964 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -269,6 +269,35 @@ Similarly consider
 When doing kind inference on {S,T} we don't want *skolems* for k1,k2,
 because they end up unifying; we want those SigTvs again.
 
+Note [ReturnTv]
+~~~~~~~~~~~~~~~
+We sometimes want to convert a checking algorithm into an inference
+algorithm. An easy way to do this is to "check" that a term has a
+metavariable as a type. But, we must be careful to allow that metavariable
+to unify with *anything*. (Well, anything that doesn't fail an occurs-check.)
+This is what ReturnTv means.
+
+For example, if we have
+
+  (undefined :: (forall a. TF1 a ~ TF2 a => a)) x
+
+we'll call (tcInfer . tcExpr) on the function expression. tcInfer will
+create a ReturnTv to represent the expression's type. We really need this
+ReturnTv to become set to (forall a. TF1 a ~ TF2 a => a) despite the fact
+that this type mentions type families and is a polytype.
+
+However, we must also be careful to make sure that the ReturnTvs really
+always do get unified with something -- we don't want these floating
+around in the solver. So, we check after running the checker to make
+sure the ReturnTv is filled. If it's not, we set it to a TauTv.
+
+We can't ASSERT that no ReturnTvs hit the solver, because they
+can if there's, say, a kind error that stops checkTauTvUpdate from
+working. This happens in test case typecheck/should_fail/T5570, for
+example.
+
+See also the commentary on #9404.
+
 \begin{code}
 -- A TyVarDetails is inside a TyVar
 data TcTyVarDetails
@@ -307,7 +336,9 @@ data MetaInfo
                    -- A TauTv is always filled in with a tau-type, which
                    -- never contains any ForAlls
 
-   | PolyTv        -- Like TauTv, but can unify with a sigma-type
+   | ReturnTv      -- Can unify with *anything*. Used to convert a
+                   -- type "checking" algorithm into a type inference algorithm.
+                   -- See Note [ReturnTv]
 
    | SigTv         -- A variant of TauTv, except that it should not be
                    -- unified with a type, only with a type variable
@@ -481,7 +512,7 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_untch = untch })
   = pp_info <> colon <> ppr untch
   where
     pp_info = case info of
-                PolyTv     -> ptext (sLit "poly")
+                ReturnTv   -> ptext (sLit "return")
                 TauTv      -> ptext (sLit "tau")
                 SigTv      -> ptext (sLit "sig")
                 FlatMetaTv -> ptext (sLit "fuv")
@@ -1133,7 +1164,7 @@ occurCheckExpand :: DynFlags -> TcTyVar -> Type -> OccCheckResult Type
 -- Check whether
 --   a) the given variable occurs in the given type.
 --   b) there is a forall in the type (unless we have -XImpredicativeTypes
---                                     or it's a PolyTv
+--                                     or it's a ReturnTv
 --   c) if it's a SigTv, ty should be a tyvar
 --
 -- We may have needed to do some type synonym unfolding in order to
@@ -1152,13 +1183,13 @@ occurCheckExpand dflags tv ty
 
     impredicative
       = case details of
-          MetaTv { mtv_info = PolyTv } -> True
-          MetaTv { mtv_info = SigTv }  -> False
-          MetaTv { mtv_info = TauTv }  -> xopt Opt_ImpredicativeTypes dflags
-                                       || isOpenTypeKind (tyVarKind tv)
+          MetaTv { mtv_info = ReturnTv } -> True
+          MetaTv { mtv_info = SigTv }    -> False
+          MetaTv { mtv_info = TauTv }    -> xopt Opt_ImpredicativeTypes dflags
+                                         || isOpenTypeKind (tyVarKind tv)
                                           -- Note [OpenTypeKind accepts foralls]
                                           -- in TcUnify
-          _other                       -> True
+          _other                         -> True
           -- We can have non-meta tyvars in given constraints
 
     -- Check 'ty' is a tyvar, or can be expanded into one
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index f5033ee08a..421d076dbf 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -46,6 +46,7 @@ import TyCon
 import TysWiredIn
 import Var
 import VarEnv
+import VarSet
 import ErrUtils
 import DynFlags
 import BasicTypes
@@ -338,10 +339,19 @@ tcSubType origin ctxt ty_actual ty_expected
                       PatSigOrigin -> TypeEqOrigin { uo_actual = ty2, uo_expected = ty1 }
                       _other       -> TypeEqOrigin { uo_actual = ty1, uo_expected = ty2 }
 
+-- | Infer a type using a type "checking" function by passing in a ReturnTv,
+-- which can unify with *anything*. See also Note [ReturnTv] in TcType
 tcInfer :: (TcType -> TcM a) -> TcM (a, TcType)
-tcInfer tc_infer = do { ty  <- newFlexiTyVarTy openTypeKind
-                      ; res <- tc_infer ty
-                      ; return (res, ty) }
+tcInfer tc_check
+  = do { tv  <- newReturnTyVar openTypeKind
+       ; let ty = mkTyVarTy tv
+       ; res <- tc_check ty
+       ; whenM (isUnfilledMetaTyVar tv) $  -- checking was uninformative
+         do { traceTc "Defaulting an un-filled ReturnTv to a TauTv" empty
+            ; tau_ty <- newFlexiTyVarTy openTypeKind
+            ; writeMetaTyVar tv tau_ty }
+       ; return (res, ty) }
+  where
 
 -----------------
 tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId)
@@ -844,7 +854,7 @@ nicer_to_update_tv1 tv1 _     _     = isSystemName (Var.varName tv1)
 ----------------
 checkTauTvUpdate :: DynFlags -> TcTyVar -> TcType -> TcM (Maybe TcType)
 --    (checkTauTvUpdate tv ty)
--- We are about to update the TauTv/PolyTv tv with ty.
+-- We are about to update the TauTv/ReturnTv tv with ty.
 -- Check (a) that tv doesn't occur in ty (occurs check)
 --       (b) that kind(ty) is a sub-kind of kind(tv)
 --
@@ -873,6 +883,9 @@ checkTauTvUpdate dflags tv ty
        ; case sub_k of
            Nothing           -> return Nothing
            Just LT           -> return Nothing
+           _  | is_return_tv -> if tv `elemVarSet` tyVarsOfType ty
+                                then return Nothing
+                                else return (Just ty1)
            _  | defer_me ty1   -- Quick test
               -> -- Failed quick test so try harder
                  case occurCheckExpand dflags tv ty1 of
@@ -882,11 +895,12 @@ checkTauTvUpdate dflags tv ty
               | otherwise   -> return (Just ty1) }
   where
     info = ASSERT2( isMetaTyVar tv, ppr tv ) metaTyVarInfo tv
+      -- See Note [ReturnTv] in TcType
+    is_return_tv = case info of { ReturnTv -> True; _ -> False }
 
     impredicative = xopt Opt_ImpredicativeTypes dflags
                  || isOpenTypeKind (tyVarKind tv)
                        -- Note [OpenTypeKind accepts foralls]
-                 || case info of { PolyTv -> True;  _ -> False }
 
     defer_me :: TcType -> Bool
     -- Checks for (a) occurrence of tv
@@ -917,7 +931,6 @@ we can instantiate it with Int#.  So we also allow such type variables
 to be instantiate with foralls.  It's a bit of a hack, but seems
 straightforward.
 
-
 Note [Conservative unification check]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When unifying (tv ~ rhs), w try to avoid creating deferred constraints
diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs
index 60748ead29..b066b404a1 100644
--- a/compiler/utils/MonadUtils.hs
+++ b/compiler/utils/MonadUtils.hs
@@ -21,6 +21,7 @@ module MonadUtils
         , anyM, allM
         , foldlM, foldlM_, foldrM
         , maybeMapM
+        , whenM
         ) where
 
 -------------------------------------------------------------------------------
@@ -149,3 +150,8 @@ foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }
 maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b))
 maybeMapM _ Nothing  = return Nothing
 maybeMapM m (Just x) = liftM Just $ m x
+
+-- | Monadic version of @when@, taking the condition in the monad
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM mb thing = do { b <- mb
+                    ; when b thing }